diff --git a/Data/Conduit/Process/Unix.hs b/Data/Conduit/Process/Unix.hs --- a/Data/Conduit/Process/Unix.hs +++ b/Data/Conduit/Process/Unix.hs @@ -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 $ diff --git a/Keter/App.hs b/Keter/App.hs --- a/Keter/App.hs +++ b/Keter/App.hs @@ -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. diff --git a/Keter/HostManager.hs b/Keter/HostManager.hs --- a/Keter/HostManager.hs +++ b/Keter/HostManager.hs @@ -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 diff --git a/Keter/LabelMap.hs b/Keter/LabelMap.hs --- a/Keter/LabelMap.hs +++ b/Keter/LabelMap.hs @@ -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 diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -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 diff --git a/Keter/Types.hs b/Keter/Types.hs --- a/Keter/Types.hs +++ b/Keter/Types.hs @@ -22,5 +22,6 @@ , BackgroundConfig (..) , RestartCount (..) , RequiresSecure + , SSLConfig (..) ) import Network.HTTP.ReverseProxy.Rewrite as X (ReverseProxyConfig (..), RewriteRule (..)) diff --git a/Keter/Types/V10.hs b/Keter/Types/V10.hs --- a/Keter/Types/V10.hs +++ b/Keter/Types/V10.hs @@ -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" diff --git a/Network/HTTP/ReverseProxy/Rewrite.hs b/Network/HTTP/ReverseProxy/Rewrite.hs --- a/Network/HTTP/ReverseProxy/Rewrite.hs +++ b/Network/HTTP/ReverseProxy/Rewrite.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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`. diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -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: . 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