keter 1.4.3.1 → 1.4.3.2
raw patch · 10 files changed
+168/−42 lines, 10 filesdep +tlsdep ~http-clientdep ~process
Dependencies added: tls
Dependency ranges changed: http-client, process
Files
- Data/Conduit/Process/Unix.hs +9/−0
- Keter/App.hs +25/−13
- Keter/HostManager.hs +12/−11
- Keter/LabelMap.hs +1/−1
- Keter/Proxy.hs +17/−4
- Keter/Types.hs +1/−0
- Keter/Types/V10.hs +47/−6
- Network/HTTP/ReverseProxy/Rewrite.hs +12/−4
- README.md +41/−1
- keter.cabal +3/−2
Data/Conduit/Process/Unix.hs view
@@ -216,6 +216,15 @@ #if MIN_VERSION_process(1, 2, 0) , delegate_ctlc = False #endif+#if MIN_VERSION_process(1, 3, 0)+ , detach_console = True+ , create_new_console = False+ , new_session = True+#endif+#if MIN_VERSION_process(1, 4, 0)+ , child_group = Nothing+ , child_user = Nothing+#endif } ignoreExceptions $ addAttachMessage pipes ph void $ forkIO $ ignoreExceptions $
Keter/App.hs view
@@ -28,7 +28,7 @@ import Data.IORef import qualified Data.Map as Map import Data.Maybe (fromMaybe)-import Data.Monoid ((<>))+import Data.Monoid ((<>), mempty) import qualified Data.Set as Set import Data.Text (pack, unpack) import Data.Text.Encoding (decodeUtf8With, encodeUtf8)@@ -49,6 +49,7 @@ import System.Posix.Files (fileAccess) import System.Posix.Types (EpochTime, GroupID, UserID) import System.Timeout (timeout)+import qualified Network.TLS as TLS data App = App { appModTime :: !(TVar (Maybe EpochTime))@@ -122,7 +123,7 @@ withReservations :: AppStartConfig -> AppId -> BundleConfig- -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host ProxyAction -> IO a)+ -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> IO a) -> IO a withReservations asc aid bconfig f = withActions asc bconfig $ \wacs backs actions -> bracketOnError (reserveHosts (ascLog asc) (ascHostManager asc) aid $ Map.keysSet actions)@@ -131,20 +132,31 @@ withActions :: AppStartConfig -> BundleConfig- -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host ProxyAction -> IO a)+ -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> IO a) -> IO a withActions asc bconfig f = loop (V.toList $ bconfigStanzas bconfig) [] [] Map.empty where loop [] wacs backs actions = f wacs backs actions loop (Stanza (StanzaWebApp wac) rs:stanzas) wacs backs actions = bracketOnError- (getPort (ascLog asc) (ascPortPool asc) >>= either throwIO return)- (releasePort (ascPortPool asc))- (\port -> loop+ (+ getPort (ascLog asc) (ascPortPool asc) >>= either throwIO+ (\p -> do+ c <- case waconfigSsl wac of+ -- todo: add loading from relative location+ SSL certFile chainCertFiles keyFile ->+ either (const mempty) (TLS.Credentials . (:[])) <$>+ TLS.credentialLoadX509Chain certFile (V.toList chainCertFiles) keyFile+ _ -> return mempty+ return (p, c)+ )+ )+ (\(port, cert) -> releasePort (ascPortPool asc) port)+ (\(port, cert) -> loop stanzas (wac { waconfigPort = port } : wacs) backs- (Map.unions $ actions : map (\host -> Map.singleton host (PAPort port (waconfigTimeout wac), rs)) hosts))+ (Map.unions $ actions : map (\host -> Map.singleton host ((PAPort port (waconfigTimeout wac), rs), cert)) hosts)) where hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac) loop (Stanza (StanzaStaticFiles sfc) rs:stanzas) wacs backs actions0 =@@ -152,19 +164,19 @@ where actions = Map.unions $ actions0- : map (\host -> Map.singleton host (PAStatic sfc, rs))+ : map (\host -> Map.singleton host ((PAStatic sfc, rs), mempty)) (Set.toList (sfconfigHosts sfc)) loop (Stanza (StanzaRedirect red) rs:stanzas) wacs backs actions0 = loop stanzas wacs backs actions where actions = Map.unions $ actions0- : map (\host -> Map.singleton host (PARedirect red, rs))+ : map (\host -> Map.singleton host ((PARedirect red, rs), mempty)) (Set.toList (redirconfigHosts red)) loop (Stanza (StanzaReverseProxy rev mid to) rs:stanzas) wacs backs actions0 = loop stanzas wacs backs actions where- actions = Map.insert (CI.mk $ reversingHost rev) (PAReverseProxy rev mid to, rs) actions0+ actions = Map.insert (CI.mk $ reversingHost rev) ((PAReverseProxy rev mid to, rs), mempty) actions0 loop (Stanza (StanzaBackground back) _:stanzas) wacs backs actions = loop stanzas wacs (back:backs) actions @@ -271,9 +283,9 @@ let httpPort = kconfigExternalHttpPort ascKeterConfig httpsPort = kconfigExternalHttpsPort ascKeterConfig (scheme, extport) =- if waconfigSsl- then ("https://", if httpsPort == 443 then "" else ':' : show httpsPort)- else ("http://", if httpPort == 80 then "" else ':' : show httpPort)+ if waconfigSsl == SSLFalse+ then ("http://", if httpPort == 80 then "" else ':' : show httpPort)+ else ("https://", if httpsPort == 443 then "" else ':' : show httpsPort) env = Map.toList $ Map.unions -- Ordering chosen specifically to precedence rules: app specific, -- plugins, global, and then auto-set Keter variables.
Keter/HostManager.hs view
@@ -28,10 +28,11 @@ import Keter.LabelMap (LabelMap) import qualified Keter.LabelMap as LabelMap import Prelude hiding (log) +import qualified Network.TLS as TLS type HMState = LabelMap HostValue -data HostValue = HVActive !AppId !ProxyAction +data HostValue = HVActive !AppId !ProxyAction !TLS.Credentials | HVReserved !AppId newtype HostManager = HostManager (IORef HMState) @@ -77,7 +78,7 @@ Nothing -> Right $ Set.singleton host Just (HVReserved aid') -> assert (aid /= aid') $ Left (host, aid') - Just (HVActive aid' _) + Just (HVActive aid' _ _) | aid == aid' -> Right Set.empty | otherwise -> Left (host, aid') where hostBS = encodeUtf8 $ CI.original host @@ -113,26 +114,26 @@ activateApp :: (LogMessage -> IO ()) -> HostManager -> AppId - -> Map.Map Host ProxyAction + -> Map.Map Host (ProxyAction, TLS.Credentials) -> IO () activateApp log (HostManager mstate) app actions = do log $ ActivatingApp app $ Map.keysSet actions atomicModifyIORef mstate $ \state0 -> (activateHelper app state0 actions, ()) -activateHelper :: AppId -> HMState -> Map Host ProxyAction -> HMState +activateHelper :: AppId -> HMState -> Map Host (ProxyAction, TLS.Credentials) -> HMState activateHelper app = Map.foldrWithKey activate where - activate host action state = - assert isOwnedByMe $ LabelMap.insert hostBS (HVActive app action) state + activate host (action, cr) state = + assert isOwnedByMe $ LabelMap.insert hostBS (HVActive app action cr) state where hostBS = encodeUtf8 $ CI.original host isOwnedByMe = LabelMap.labelAssigned hostBS state && case LabelMap.lookup hostBS state of Nothing -> False Just (HVReserved app') -> app == app' - Just (HVActive app' _) -> app == app' + Just (HVActive app' _ _) -> app == app' deactivateApp :: (LogMessage -> IO ()) -> HostManager @@ -155,13 +156,13 @@ isOwnedByMe = LabelMap.labelAssigned hostBS state && case LabelMap.lookup hostBS state of Nothing -> False - Just (HVActive app' _) -> app == app' + Just (HVActive app' _ _) -> app == app' Just HVReserved {} -> False reactivateApp :: (LogMessage -> IO ()) -> HostManager -> AppId - -> Map Host ProxyAction + -> Map Host (ProxyAction, TLS.Credentials) -> Set Host -> IO () reactivateApp log (HostManager mstate) app actions hosts = do @@ -171,10 +172,10 @@ lookupAction :: HostManager -> HostBS - -> IO (Maybe ProxyAction) + -> IO (Maybe (ProxyAction, TLS.Credentials)) lookupAction (HostManager mstate) host = do state <- readIORef mstate return $ case LabelMap.lookup (CI.original host) state of Nothing -> Nothing - Just (HVActive _ action) -> Just action + Just (HVActive _ action cert) -> Just (action, cert) Just (HVReserved _) -> Nothing
Keter/LabelMap.hs view
@@ -240,7 +240,7 @@ lookupTree _ EmptyLabelMap = Nothing lookupTree [l] (Static t) = Map.lookup (CI.mk l) t >>= getPortEntry---lookupTree (_:_) (Wildcard w) = getPortEntry $ w+lookupTree [_] (Wildcard w) = getPortEntry $ w lookupTree [l] (WildcardExcept w t) = case Map.lookup (CI.mk l) t >>= getPortEntry of Just e -> Just e
Keter/Proxy.hs view
@@ -9,7 +9,7 @@ ) where import Blaze.ByteString.Builder (copyByteString)-import Control.Applicative ((<|>))+import Control.Applicative ((<$>), (<|>)) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8@@ -43,9 +43,10 @@ import Network.Wai.Middleware.Gzip (gzip) import Prelude hiding (FilePath, (++)) import WaiAppStatic.Listing (defaultListing)+import qualified Network.TLS as TLS -- | Mapping from virtual hostname to port number.-type HostLookup = ByteString -> IO (Maybe ProxyAction)+type HostLookup = ByteString -> IO (Maybe (ProxyAction, TLS.Credentials)) reverseProxy :: Bool -> Int -> Manager -> HostLookup -> ListeningPort -> IO ()@@ -57,12 +58,24 @@ case listener of LPInsecure host port -> (Warp.runSettings (warp host port), False) LPSecure host port cert chainCerts key -> (WarpTLS.runTLS- (WarpTLS.tlsSettingsChain+ (connectClientCertificates hostLookup $ WarpTLS.tlsSettingsChain cert (V.toList chainCerts) key) (warp host port), True) +connectClientCertificates :: HostLookup -> WarpTLS.TLSSettings -> WarpTLS.TLSSettings+connectClientCertificates hl s =+ let+ newHooks@TLS.ServerHooks{..} = WarpTLS.tlsServerHooks s+ -- todo: add nested lookup+ newOnServerNameIndication (Just n) =+ maybe mempty snd <$> hl (S8.pack n)+ newOnServerNameIndication Nothing =+ return mempty -- we could return default certificate here+ in+ s { WarpTLS.tlsServerHooks = newHooks{TLS.onServerNameIndication = newOnServerNameIndication}}+ withClient :: Bool -- ^ is secure? -> Bool -- ^ use incoming request header for IP address -> Int -- ^ time bound for connections@@ -120,7 +133,7 @@ else hostLookup host' case mport of Nothing -> return (def, WPRResponse $ unknownHostResponse host)- Just (action, requiresSecure)+ Just ((action, requiresSecure), _) | requiresSecure && not isSecure -> performHttpsRedirect host req | otherwise -> performAction req action
Keter/Types.hs view
@@ -22,5 +22,6 @@ , BackgroundConfig (..) , RestartCount (..) , RequiresSecure+ , SSLConfig (..) ) import Network.HTTP.ReverseProxy.Rewrite as X (ReverseProxyConfig (..), RewriteRule (..))
Keter/Types/V10.hs view
@@ -8,8 +8,8 @@ import Control.Applicative ((<$>), (<*>), (<|>)) import Data.Aeson (Object, ToJSON (..)) import Data.Aeson (FromJSON (..),- Value (Object, String),- withObject, (.!=), (.:),+ Value (Object, String, Bool),+ withObject, withBool, (.!=), (.:), (.:?)) import Data.Aeson (Value (Bool), object, (.=)) import qualified Data.CaseInsensitive as CI@@ -251,7 +251,7 @@ instance ParseYamlFile StaticFilesConfig where parseYamlFile basedir = withObject "StaticFilesConfig" $ \o -> StaticFilesConfig <$> lookupBase basedir o "root"- <*> (Set.map CI.mk <$> ((o .: "hosts" <|> (Set.singleton <$> (o .: "host")))))+ <*> (Set.map CI.mk <$> (o .: "hosts" <|> (Set.singleton <$> (o .: "host")))) <*> o .:? "directory-listing" .!= False <*> o .:? "middleware" .!= [] <*> o .:? "connection-time-bound"@@ -341,13 +341,54 @@ type IsSecure = Bool +data SSLConfig+ = SSLFalse+ | SSLTrue+ | SSL !F.FilePath !(V.Vector F.FilePath) !F.FilePath+ deriving (Show, Eq)++instance ParseYamlFile SSLConfig where+ parseYamlFile _ v@(Bool _) =+ withBool "ssl" ( \b ->+ return (if b then SSLTrue else SSLFalse) ) v+ parseYamlFile basedir v = withObject "ssl" ( \o -> do+ mcert <- lookupBaseMaybe basedir o "certificate"+ mkey <- lookupBaseMaybe basedir o "key"+ case (mcert, mkey) of+ (Just cert, Just key) -> do+ chainCerts <- o .:? "chain-certificates"+ >>= maybe (return V.empty) (parseYamlFile basedir)+ return $ SSL cert chainCerts key+ _ -> return SSLFalse+ ) v++instance ToJSON SSLConfig where+ toJSON SSLTrue = Bool True+ toJSON SSLFalse = Bool False+ toJSON (SSL c cc k) = object [ "certificate" .= c+ , "chain-certificates" .= cc+ , "key" .= k+ ]+instance FromJSON SSLConfig where+ parseJSON v@(Bool _) = withBool "ssl" ( \b ->+ return (if b then SSLTrue else SSLFalse) ) v+ parseJSON v = withObject "ssl" ( \o -> do+ mcert <- o .:? "certificate"+ mkey <- o .:? "key"+ case (mcert, mkey) of+ (Just cert, Just key) -> do+ chainCerts <- o .:? "chain-certificates" .!= V.empty+ return $ SSL cert chainCerts key+ _ -> return SSLFalse -- fail "Must provide both certificate and key files"+ ) v+ data WebAppConfig port = WebAppConfig { waconfigExec :: !F.FilePath , waconfigArgs :: !(Vector Text) , waconfigEnvironment :: !(Map Text Text) , waconfigApprootHost :: !Host -- ^ primary host, used for approot , waconfigHosts :: !(Set Host) -- ^ all hosts, not including the approot host- , waconfigSsl :: !Bool+ , waconfigSsl :: !SSLConfig , waconfigPort :: !port , waconfigForwardEnv :: !(Set Text) , waconfigTimeout :: !(Maybe Int)@@ -362,7 +403,7 @@ , waconfigEnvironment = Map.empty , waconfigApprootHost = CI.mk host , waconfigHosts = Set.map CI.mk hosts- , waconfigSsl = ssl+ , waconfigSsl = if ssl then SSLTrue else SSLFalse , waconfigPort = () , waconfigForwardEnv = Set.empty , waconfigTimeout = Nothing@@ -385,7 +426,7 @@ <*> o .:? "env" .!= Map.empty <*> return ahost <*> return hosts- <*> o .:? "ssl" .!= False+ <*> o .:? "ssl" .!= SSLFalse <*> return () <*> o .:? "forward-env" .!= Set.empty <*> o .:? "connection-time-bound"
Network/HTTP/ReverseProxy/Rewrite.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-} module Network.HTTP.ReverseProxy.Rewrite ( ReverseProxyConfig (..) , RewriteRule (..)@@ -115,7 +116,16 @@ mkRequest :: ReverseProxyConfig -> Wai.Request -> Request mkRequest rpConfig request =- def { method = Wai.requestMethod request+#if MIN_VERSION_http_client(0, 5, 0)+ NHC.defaultRequest+ { NHC.checkResponse = \_ _ -> return ()+ , NHC.responseTimeout = maybe NHC.responseTimeoutNone NHC.responseTimeoutMicro $ reverseTimeout rpConfig+#else+ def+ { NHC.checkStatus = \_ _ _ -> Nothing+ , NHC.responseTimeout = reverseTimeout rpConfig+#endif+ , method = Wai.requestMethod request , secure = reverseUseSSL rpConfig , host = encodeUtf8 $ reversedHost rpConfig , port = reversedPort rpConfig@@ -128,8 +138,6 @@ Wai.KnownLength n -> RequestBodyStream (fromIntegral n) ($ Wai.requestBody request) , decompress = const False , redirectCount = 0- , checkStatus = \_ _ _ -> Nothing- , responseTimeout = reverseTimeout rpConfig , cookieJar = Nothing } where
README.md view
@@ -226,7 +226,12 @@ This has not yet been confirmed to work in production. If you use this, please report either its success or failure back to me.+ + Additionally, to make sure that nginx does not reset the `Host` header + (which keter uses to choose the right target), you will need to add: + proxy_set_header Host $host;+ * Keter does not handle password-protected SSL key files well. When provided with such a key file, unlike Apache and Nginx, Keter will not pause to ask for the password. Instead, your https connections will merely stall.@@ -269,6 +274,41 @@ certificate: certificate2.pem ``` ++An alternative way to make this possible is adding the following `ssl:` argument+to the `keter.yaml` file in your Yesod app's `config folder` as follows:++```+stanzas:+ - type: webapp+ exec: ../yourproject+ ssl:+ key: /opt/keter/etc/cert/yourproject.key+ certificate: /opt/keter/etc/cert/yourproject.crt+ chain-certificates: []+```++If you don't have your certificates bundled in one `.crt` file, you should add+the other certificates in the following order++```+ ssl:+ [..]+ chain-certificates:+ - /opt/keter/etc/middle.crt+ - /opt/keter/etc/root.crt+```++This way you can designate certificates per Yesod App while still having one SSL certificate+in your main `/opt/keter/etc/keter-config.yaml` for your other Yesod apps to default to+if they don't have this `ssl:` argument in their `config/keter.yaml`.++NOTE: If you get an error that a Bool was expected instead of an Object when adding the `ssl:`+argument, then for this to work you might need to build Keter from Github, because at the time+of writing the version of Keter on Hackage does not have this functionality. Just clone or +download this repository and build it using stack.++ ## FAQ * Keter spawns multiple failing process when run with `sudo start keter`.@@ -276,7 +316,7 @@ Try to run `sudo /opt/keter/bin/keter /opt/keter/etc/keter-config.yaml`. If it fails with `keter: etc/certificate.pem: openBinaryFile: does not exist` or something like it, you may need to provide valid SSL certificates and keys- or disable HTTPS, by uncommenting the key and certificate lines from+ or disable HTTPS, by commenting the key and certificate lines from `/opt/keter/etc/keter-config.yaml`.
keter.cabal view
@@ -1,5 +1,5 @@ Name: keter-Version: 1.4.3.1+Version: 1.4.3.2 Synopsis: Web application deployment manager, focusing on Haskell web frameworks Description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/keter>. Homepage: http://www.yesodweb.com/@@ -43,7 +43,7 @@ , http-reverse-proxy >= 0.4.2 && < 0.5 , unix >= 2.5 , wai-app-static >= 3.1 && < 3.2- , wai >= 3.0 && < 3.1+ , wai >= 3.0 && < 3.3 , wai-extra >= 3.0.3 && < 3.1 , http-types , regex-tdfa >= 1.1@@ -61,6 +61,7 @@ , stm >= 2.4 , async , lifted-base+ , tls >= 1.3.4 if impl(ghc < 7.6) build-depends: ghc-prim