diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,14 @@ +## 1.5 + +* Builds with `process` 1.6 +* add dependency for `tls-session-manager` +* Add show instance for App +* Add ensure alive timeout config +* Add `nc` example in incoming +* Change to github actions because travis ci stopped working. +* Fix hackage issues in cabal file +* Fix breaking changes with warp-tls. + ## 1.4.3.1 * Add cabal flag `system-filepath` for compatibility with older versions of fsnotify. 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 @@ -33,7 +33,7 @@ import Control.Monad (void) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 -import Data.Conduit (Source, ($$)) +import Data.Conduit (ConduitM, (.|), runConduit) import Data.Conduit.Binary (sinkHandle, sourceHandle) import qualified Data.Conduit.List as CL import Data.IORef (IORef, newIORef, readIORef, @@ -61,7 +61,9 @@ ProcessHandle__ (..)) processHandleMVar :: ProcessHandle -> MVar ProcessHandle__ -#if MIN_VERSION_process(1, 2, 0) +#if MIN_VERSION_process(1, 6, 0) +processHandleMVar (ProcessHandle m _ _) = m +#elif MIN_VERSION_process(1, 2, 0) processHandleMVar (ProcessHandle m _) = m #else processHandleMVar (ProcessHandle m) = m @@ -189,7 +191,7 @@ -> [ByteString] -- ^ args -> Maybe [(ByteString, ByteString)] -- ^ environment -> Maybe ByteString -- ^ working directory - -> Maybe (Source IO ByteString) -- ^ stdin + -> Maybe (ConduitM () ByteString IO ()) -- ^ stdin -> (ByteString -> IO ()) -- ^ both stdout and stderr will be sent to this location -> IO ProcessHandle forkExecuteLog cmd args menv mwdir mstdin rlog = bracketOnError @@ -213,6 +215,9 @@ , std_err = UseHandle writerH , close_fds = True , create_group = True +#if MIN_VERSION_process(1, 5, 0) + , use_process_jobs = False +#endif #if MIN_VERSION_process(1, 2, 0) , delegate_ctlc = False #endif @@ -228,10 +233,10 @@ } ignoreExceptions $ addAttachMessage pipes ph void $ forkIO $ ignoreExceptions $ - (sourceHandle readerH $$ CL.mapM_ rlog) `finally` hClose readerH + (runConduit $ sourceHandle readerH .| CL.mapM_ rlog) `finally` hClose readerH case (min, mstdin) of (Just h, Just source) -> void $ forkIO $ ignoreExceptions $ - (source $$ sinkHandle h) `finally` hClose h + (runConduit $ source .| sinkHandle h) `finally` hClose h (Nothing, Nothing) -> return () _ -> error $ "Invariant violated: Data.Conduit.Process.Unix.forkExecuteLog" return ph diff --git a/Keter/App.hs b/Keter/App.hs --- a/Keter/App.hs +++ b/Keter/App.hs @@ -2,6 +2,9 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NamedFieldPuns #-} + module Keter.App ( App , AppStartConfig (..) @@ -17,14 +20,15 @@ import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM import Control.Exception (IOException, bracketOnError, - throwIO, try) -import Control.Monad (void, when) + throwIO, try, catch) +import Control.Monad (void, when, liftM) import qualified Data.CaseInsensitive as CI import Data.Conduit.LogFile (RotatingLog) import qualified Data.Conduit.LogFile as LogFile import Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker, monitorProcess, terminateMonitoredProcess) +import Data.Foldable (for_) import Data.IORef import qualified Data.Map as Map import Data.Maybe (fromMaybe) @@ -42,10 +46,10 @@ import Keter.HostManager hiding (start) import Keter.PortPool (PortPool, getPort, releasePort) import Keter.Types -import qualified Network +import Network.Socket import Prelude hiding (FilePath) import System.Environment (getEnvironment) -import System.IO (hClose) +import System.IO (hClose, IOMode(..)) import System.Posix.Files (fileAccess) import System.Posix.Types (EpochTime, GroupID, UserID) import System.Timeout (timeout) @@ -61,10 +65,13 @@ , appAsc :: !AppStartConfig , appRlog :: !(TVar (Maybe RotatingLog)) } +instance Show App where + show App {appId, ..} = "App{appId=" <> show appId <> "}" data RunningWebApp = RunningWebApp - { rwaProcess :: !MonitoredProcess - , rwaPort :: !Port + { rwaProcess :: !MonitoredProcess + , rwaPort :: !Port + , rwaEnsureAliveTimeOut :: !Int } newtype RunningBackgroundApp = RunningBackgroundApp @@ -132,26 +139,23 @@ withActions :: AppStartConfig -> BundleConfig - -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> 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 + -- todo: add loading from relative location + loadCert (SSL certFile chainCertFiles keyFile) = + either (const mempty) (TLS.Credentials . (:[])) + <$> TLS.credentialLoadX509Chain certFile (V.toList chainCertFiles) keyFile + loadCert _ = return mempty + 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 - (\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) - ) + (getPort (ascLog asc) (ascPortPool asc) >>= either throwIO + (\p -> fmap (p,) <$> loadCert $ waconfigSsl wac) ) - (\(port, cert) -> releasePort (ascPortPool asc) port) + (\(port, _) -> releasePort (ascPortPool asc) port) (\(port, cert) -> loop stanzas (wac { waconfigPort = port } : wacs) @@ -159,24 +163,27 @@ (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 = - loop stanzas wacs backs actions + loop (Stanza (StanzaStaticFiles sfc) rs:stanzas) wacs backs actions0 = do + cert <- loadCert $ sfconfigSsl sfc + loop stanzas wacs backs (actions cert) where - actions = Map.unions + actions cert = Map.unions $ actions0 - : map (\host -> Map.singleton host ((PAStatic sfc, rs), mempty)) + : map (\host -> Map.singleton host ((PAStatic sfc, rs), cert)) (Set.toList (sfconfigHosts sfc)) - loop (Stanza (StanzaRedirect red) rs:stanzas) wacs backs actions0 = - loop stanzas wacs backs actions + loop (Stanza (StanzaRedirect red) rs:stanzas) wacs backs actions0 = do + cert <- loadCert $ redirconfigSsl red + loop stanzas wacs backs (actions cert) where - actions = Map.unions + actions cert = Map.unions $ actions0 - : map (\host -> Map.singleton host ((PARedirect red, rs), mempty)) + : map (\host -> Map.singleton host ((PARedirect red, rs), cert)) (Set.toList (redirconfigHosts red)) - loop (Stanza (StanzaReverseProxy rev mid to) rs:stanzas) wacs backs actions0 = - loop stanzas wacs backs actions + loop (Stanza (StanzaReverseProxy rev mid to) rs:stanzas) wacs backs actions0 = do + cert <- loadCert $ reversingUseSSL rev + loop stanzas wacs backs (actions cert) where - actions = Map.insert (CI.mk $ reversingHost rev) ((PAReverseProxy rev mid to, rs), mempty) actions0 + actions cert = Map.insert (CI.mk $ reversingHost rev) ((PAReverseProxy rev mid to, rs), cert) actions0 loop (Stanza (StanzaBackground back) _:stanzas) wacs backs actions = loop stanzas wacs (back:backs) actions @@ -209,7 +216,10 @@ ascLog SanityChecksPassed f where - go (Stanza (StanzaWebApp WebAppConfig {..}) _) = isExec waconfigExec + go (Stanza (StanzaWebApp WebAppConfig {..}) _) = do + isExec waconfigExec + for_ waconfigEnsureAliveTimeout + $ \x -> when (x < 1) $ throwIO $ EnsureAliveShouldBeBiggerThenZero x go (Stanza (StanzaBackground BackgroundConfig {..}) _) = isExec bgconfigExec go _ = return () @@ -312,6 +322,7 @@ $ \mp -> f RunningWebApp { rwaProcess = mp , rwaPort = waconfigPort + , rwaEnsureAliveTimeOut = fromMaybe (90 * 1000 * 1000) waconfigEnsureAliveTimeout } where name = @@ -332,17 +343,44 @@ where testApp :: Port -> IO Bool testApp port = do - res <- timeout (90 * 1000 * 1000) testApp' + res <- timeout rwaEnsureAliveTimeOut testApp' return $ fromMaybe False res where testApp' = do threadDelay $ 2 * 1000 * 1000 - eres <- try $ Network.connectTo "127.0.0.1" $ Network.PortNumber $ fromIntegral port + eres <- try $ connectTo "127.0.0.1" $ show port case eres of Left (_ :: IOException) -> testApp' Right handle -> do hClose handle return True + connectTo host serv = do + let hints = defaultHints { addrFlags = [AI_ADDRCONFIG] + , addrSocketType = Stream } + addrs <- getAddrInfo (Just hints) (Just host) (Just serv) + firstSuccessful $ map tryToConnect addrs + where + tryToConnect addr = + bracketOnError + (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + (close) -- only done if there's an error + (\sock -> do + connect sock (addrAddress addr) + socketToHandle sock ReadWriteMode + ) + firstSuccessful = go Nothing + where + go _ (p:ps) = do + r <- tryIO p + case r of + Right x -> return x + Left e -> go (Just e) ps + -- All operations failed, throw error if one exists + go Nothing [] = ioError $ userError $ "connectTo firstSuccessful: empty list" + go (Just e) [] = throwIO e + tryIO :: IO a -> IO (Either IOException a) + tryIO m = catch (liftM Right m) (return . Left) + withBackgroundApps :: AppStartConfig -> AppId diff --git a/Keter/AppManager.hs b/Keter/AppManager.hs --- a/Keter/AppManager.hs +++ b/Keter/AppManager.hs @@ -215,9 +215,11 @@ processAction Nothing Terminate = return Nothing processAction (Just app) Terminate = do + log $ Terminating $ show app App.terminate app return Nothing processAction Nothing (Reload input) = do + log $ ReloadFrom Nothing $ show input eres <- E.try $ App.start appStartConfig appid input case eres of Left e -> do @@ -225,6 +227,7 @@ return Nothing Right app -> return $ Just app processAction (Just app) (Reload input) = do + log $ ReloadFrom (Just $ show app) (show input) eres <- E.try $ App.reload app input case eres of Left e -> do diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -38,7 +38,7 @@ import qualified Data.Text.Read import Data.Time (getCurrentTime) import Data.Yaml.FilePath -import qualified Network.HTTP.Conduit as HTTP (conduitManagerSettings, +import qualified Network.HTTP.Conduit as HTTP (tlsManagerSettings, newManager) import Prelude hiding (FilePath, log) import System.Directory (createDirectoryIfMissing, @@ -159,15 +159,18 @@ _ <- FSN.watchTree wm (fromString incoming) (const True) $ \e -> do e' <- case e of - FSN.Removed fp _ -> do + FSN.Removed fp _ _ -> do log $ WatchedFile "removed" (fromFilePath fp) return $ Left $ fromFilePath fp - FSN.Added fp _ -> do + FSN.Added fp _ _ -> do log $ WatchedFile "added" (fromFilePath fp) return $ Right $ fromFilePath fp - FSN.Modified fp _ -> do + FSN.Modified fp _ _ -> do log $ WatchedFile "modified" (fromFilePath fp) return $ Right $ fromFilePath fp + _ -> do + log $ WatchedFile "unknown" [] + return $ Left [] case e' of Left fp -> when (isKeter fp) $ AppMan.terminateApp appMan $ getAppname fp Right fp -> when (isKeter fp) $ AppMan.addApp appMan $ incoming fp @@ -208,7 +211,7 @@ startListening :: KeterConfig -> HostMan.HostManager -> IO () startListening KeterConfig {..} hostman = do - manager <- HTTP.newManager HTTP.conduitManagerSettings + manager <- HTTP.newManager HTTP.tlsManagerSettings runAndBlock kconfigListeners $ Proxy.reverseProxy kconfigIpFromHeader -- calculate the number of microseconds since the diff --git a/Keter/PortPool.hs b/Keter/PortPool.hs --- a/Keter/PortPool.hs +++ b/Keter/PortPool.hs @@ -16,7 +16,7 @@ import Control.Concurrent.MVar import Control.Exception import Keter.Types -import qualified Network +import Network.Socket import Prelude hiding (log) data PPState = PPState @@ -38,13 +38,13 @@ case ppAvail of p:ps -> do let next = PPState ps ppRecycled - res <- try $ Network.listenOn $ Network.PortNumber $ fromIntegral p + res <- try $ listenOn $ show p case res of Left (_ :: SomeException) -> do log $ RemovingPort p loop next - Right socket -> do - res' <- try $ Network.sClose socket + Right socket' -> do + res' <- try $ close socket' case res' of Left e -> do $logEx log e @@ -55,6 +55,22 @@ case ppRecycled [] of [] -> return (PPState [] id, Left $ toException NoPortsAvailable) ps -> loop $ PPState ps id + + listenOn port = do + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + addr:_ <- getAddrInfo (Just hints) Nothing (Just port) + bracketOnError + (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + (close) + (\sock -> do + setSocketOption sock ReuseAddr 1 + bind sock (addrAddress addr) + listen sock maxListenQueue + return sock + ) -- | Return a port to the recycled collection of the pool. Note that recycling -- puts the new ports at the end of the queue (FIFO), so that if an application diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} -- | A light-weight, minimalistic reverse HTTP proxy. module Keter.Proxy ( reverseProxy @@ -14,7 +15,11 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.CaseInsensitive as CI +#if MIN_VERSION_http_reverse_proxy(0,6,0) +import Network.Wai.Middleware.Gzip (def) +#else import Data.Default (Default (..)) +#endif import Data.Monoid (mappend, mempty) import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) @@ -22,6 +27,15 @@ import Keter.Types import Keter.Types.Middleware import Network.HTTP.Conduit (Manager) + +#if MIN_VERSION_http_reverse_proxy(0,4,2) +import Network.HTTP.ReverseProxy (defaultLocalWaiProxySettings) +#endif + +#if MIN_VERSION_http_reverse_proxy(0,6,0) +import Network.HTTP.ReverseProxy (defaultWaiProxySettings) +#endif + import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest), SetIpHeader (..), WaiProxyResponse (..), @@ -40,32 +54,42 @@ ssListing, staticApp) import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WarpTLS as WarpTLS -import Network.Wai.Middleware.Gzip (gzip) +import qualified Network.TLS.SessionManager as TLSSession +import Network.Wai.Middleware.Gzip (gzip, GzipSettings(..), GzipFiles(..)) import Prelude hiding (FilePath, (++)) import WaiAppStatic.Listing (defaultListing) import qualified Network.TLS as TLS +#if !MIN_VERSION_http_reverse_proxy(0,6,0) +defaultWaiProxySettings = def +#endif + +#if !MIN_VERSION_http_reverse_proxy(0,4,2) +defaultLocalWaiProxySettings = def +#endif + + -- | Mapping from virtual hostname to port number. type HostLookup = ByteString -> IO (Maybe (ProxyAction, TLS.Credentials)) reverseProxy :: Bool -> Int -> Manager -> HostLookup -> ListeningPort -> IO () reverseProxy useHeader timeBound manager hostLookup listener = - run $ gzip def $ withClient isSecure useHeader timeBound manager hostLookup + run $ gzip def{gzipFiles = GzipPreCompressed GzipIgnore} $ withClient isSecure useHeader timeBound manager hostLookup where warp host port = Warp.setHost host $ Warp.setPort port Warp.defaultSettings (run, isSecure) = case listener of LPInsecure host port -> (Warp.runSettings (warp host port), False) - LPSecure host port cert chainCerts key -> (WarpTLS.runTLS - (connectClientCertificates hostLookup $ WarpTLS.tlsSettingsChain + LPSecure host port cert chainCerts key session -> (WarpTLS.runTLS + (connectClientCertificates hostLookup session $ WarpTLS.tlsSettingsChain cert (V.toList chainCerts) key) (warp host port), True) -connectClientCertificates :: HostLookup -> WarpTLS.TLSSettings -> WarpTLS.TLSSettings -connectClientCertificates hl s = +connectClientCertificates :: HostLookup -> Bool -> WarpTLS.TLSSettings -> WarpTLS.TLSSettings +connectClientCertificates hl session s = let newHooks@TLS.ServerHooks{..} = WarpTLS.tlsServerHooks s -- todo: add nested lookup @@ -74,7 +98,8 @@ newOnServerNameIndication Nothing = return mempty -- we could return default certificate here in - s { WarpTLS.tlsServerHooks = newHooks{TLS.onServerNameIndication = newOnServerNameIndication}} + s { WarpTLS.tlsServerHooks = newHooks{TLS.onServerNameIndication = newOnServerNameIndication} + , WarpTLS.tlsSessionManagerConfig = if session then (Just TLSSession.defaultConfig) else Nothing } withClient :: Bool -- ^ is secure? -> Bool -- ^ use incoming request header for IP address @@ -85,7 +110,7 @@ withClient isSecure useHeader bound manager hostLookup = waiProxyToSettings (error "First argument to waiProxyToSettings forced, even thought wpsGetDest provided") - def + defaultWaiProxySettings { wpsSetIpHeader = if useHeader then SIHFromHeader @@ -106,7 +131,7 @@ -- leak from occurring. addjustGlobalBound :: Maybe Int -> LocalWaiProxySettings - addjustGlobalBound to = go `setLpsTimeBound` def + addjustGlobalBound to = go `setLpsTimeBound` defaultLocalWaiProxySettings where go = case to <|> Just bound of Just x | x > 0 -> Just x @@ -115,7 +140,7 @@ getDest :: Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse) getDest req = case Wai.requestHeaderHost req of - Nothing -> return (def, WPRResponse missingHostResponse) + Nothing -> return (defaultLocalWaiProxySettings, WPRResponse missingHostResponse) Just host -> processHost req host processHost :: Wai.Request -> S.ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse) @@ -132,7 +157,7 @@ then return Nothing else hostLookup host' case mport of - Nothing -> return (def, WPRResponse $ unknownHostResponse host) + Nothing -> return (defaultLocalWaiProxySettings, WPRResponse $ unknownHostResponse host) Just ((action, requiresSecure), _) | requiresSecure && not isSecure -> performHttpsRedirect host req | otherwise -> performAction req action @@ -146,6 +171,7 @@ , redirconfigStatus = 301 , redirconfigActions = V.singleton $ RedirectAction SPAny $ RDPrefix True host' Nothing + , redirconfigSsl = SSLTrue } performAction req (PAPort port tbound) = diff --git a/Keter/Types.hs b/Keter/Types.hs --- a/Keter/Types.hs +++ b/Keter/Types.hs @@ -22,6 +22,5 @@ , BackgroundConfig (..) , RestartCount (..) , RequiresSecure - , SSLConfig (..) ) import Network.HTTP.ReverseProxy.Rewrite as X (ReverseProxyConfig (..), RewriteRule (..)) diff --git a/Keter/Types/Common.hs b/Keter/Types/Common.hs --- a/Keter/Types/Common.hs +++ b/Keter/Types/Common.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + module Keter.Types.Common ( module Keter.Types.Common , FilePath @@ -13,7 +15,9 @@ ) where import Control.Exception (Exception, SomeException) -import Data.Aeson (Object) +import Data.Aeson (Object, FromJSON, ToJSON, + Value(Bool), (.=), (.!=), (.:?), + withObject, withBool, object) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI, original) import Data.Map (Map) @@ -21,10 +25,13 @@ import qualified Data.Set as Set import Data.Text (Text, pack, unpack) import Data.Typeable (Typeable) +import Data.Yaml.FilePath +import Data.Vector (Vector) +import qualified Data.Vector as V import qualified Data.Yaml import qualified Language.Haskell.TH.Syntax as TH import System.Exit (ExitCode) -import System.FilePath (takeBaseName) +import System.FilePath (FilePath, takeBaseName) -- | Name of the application. Should just be the basename of the application -- file. @@ -77,9 +84,13 @@ | DeactivatingApp AppId (Set Host) | ReactivatingApp AppId (Set Host) (Set Host) | WatchedFile Text FilePath + | ReloadFrom (Maybe String) String + | Terminating String instance Show LogMessage where show (ProcessCreated f) = "Created process: " ++ f + show (ReloadFrom app input) = "Reloading from: " ++ show app ++ " to " ++ show input + show (Terminating app) = "Terminating " ++ show app show (InvalidBundle f e) = concat [ "Unable to parse bundle file '" , f @@ -144,6 +155,7 @@ | CannotReserveHosts !AppId !(Map Host AppId) | FileNotExecutable !FilePath | ExecutableNotFound !FilePath + | EnsureAliveShouldBeBiggerThenZero { keterExceptionGot:: !Int } deriving (Show, Typeable) instance Exception KeterException @@ -164,3 +176,44 @@ instance Show AppId where show AIBuiltin = "/builtin/" show (AINamed t) = unpack t + +data SSLConfig + = SSLFalse + | SSLTrue + | SSL !FilePath !(Vector FilePath) !FilePath + deriving (Show, Eq, Ord) + +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 diff --git a/Keter/Types/Middleware.hs b/Keter/Types/Middleware.hs --- a/Keter/Types/Middleware.hs +++ b/Keter/Types/Middleware.hs @@ -9,7 +9,6 @@ import Control.Monad import Control.Arrow ((***)) -import Control.Applicative -- various Middlewares import Network.Wai.Middleware.AcceptOverride (acceptOverride) diff --git a/Keter/Types/V04.hs b/Keter/Types/V04.hs --- a/Keter/Types/V04.hs +++ b/Keter/Types/V04.hs @@ -5,6 +5,7 @@ import Control.Applicative import Data.Aeson +import Data.Bool import Data.Conduit.Network (HostPreference) import Data.Default import qualified Data.Set as Set @@ -15,6 +16,7 @@ import Network.HTTP.ReverseProxy.Rewrite import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WarpTLS as WarpTLS +import qualified Network.TLS.SessionManager as TLSSession import Prelude hiding (FilePath) data AppConfig = AppConfig @@ -113,7 +115,7 @@ <*> o .:? "ip-from-header" .!= False <*> o .:? "connection-time-bound" .!= fiveMinutes -data TLSConfig = TLSConfig !Warp.Settings !WarpTLS.TLSSettings +data TLSConfig = TLSConfig !Warp.Settings !FilePath !FilePath (Maybe TLSSession.Config) instance ParseYamlFile TLSConfig where parseYamlFile basedir = withObject "TLSConfig" $ \o -> do @@ -121,14 +123,12 @@ key <- lookupBase basedir o "key" host <- (fmap fromString <$> o .:? "host") .!= "*" port <- o .:? "port" .!= 443 + session <- bool Nothing (Just TLSSession.defaultConfig) <$> o .:? "session" .!= False return $! TLSConfig - ( Warp.setHost host - $ Warp.setPort port - Warp.defaultSettings) - WarpTLS.defaultTlsSettings - { WarpTLS.certFile = cert - , WarpTLS.keyFile = key - } + (Warp.setHost host $ Warp.setPort port Warp.defaultSettings) + cert + key + session -- | Controls execution of the nginx thread. Follows the settings type pattern. -- See: . diff --git a/Keter/Types/V10.hs b/Keter/Types/V10.hs --- a/Keter/Types/V10.hs +++ b/Keter/Types/V10.hs @@ -6,18 +6,16 @@ module Keter.Types.V10 where import Control.Applicative ((<$>), (<*>), (<|>)) -import Data.Aeson (Object, ToJSON (..)) -import Data.Aeson (FromJSON (..), +import Data.Aeson (FromJSON (..), ToJSON (..), Object, Value (Object, String, Bool), - withObject, withBool, (.!=), (.:), - (.:?)) -import Data.Aeson (Value (Bool), object, (.=)) + withObject, (.!=), (.:), + (.:?), object, (.=)) import qualified Data.CaseInsensitive as CI import Data.Conduit.Network (HostPreference) import Data.Default import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust) import qualified Data.Set as Set import Data.String (fromString) import Data.Vector (Vector) @@ -36,7 +34,7 @@ data BundleConfig = BundleConfig { bconfigStanzas :: !(Vector (Stanza ())) , bconfigPlugins :: !Object -- ^ settings used for plugins - } + } deriving Show instance ToCurrent BundleConfig where type Previous BundleConfig = V04.BundleConfig @@ -70,6 +68,7 @@ data ListeningPort = LPSecure !HostPreference !Port !F.FilePath !(V.Vector F.FilePath) !F.FilePath + !Bool | LPInsecure !HostPreference !Port instance ParseYamlFile ListeningPort where @@ -77,6 +76,7 @@ host <- (fmap fromString <$> o .:? "host") .!= "*" mcert <- lookupBaseMaybe basedir o "certificate" mkey <- lookupBaseMaybe basedir o "key" + session <- o .:? "session" .!= False case (mcert, mkey) of (Nothing, Nothing) -> do port <- o .:? "port" .!= 80 @@ -85,7 +85,7 @@ port <- o .:? "port" .!= 443 chainCerts <- o .:? "chain-certificates" >>= maybe (return V.empty) (parseYamlFile basedir) - return $ LPSecure host port cert chainCerts key + return $ LPSecure host port cert chainCerts key session _ -> fail "Must provide both certificate and key files" data KeterConfig = KeterConfig @@ -121,12 +121,13 @@ } where getSSL Nothing = V.empty - getSSL (Just (V04.TLSConfig s ts)) = V.singleton $ LPSecure + getSSL (Just (V04.TLSConfig s cert key session)) = V.singleton $ LPSecure (Warp.getHost s) (Warp.getPort s) - (WarpTLS.certFile ts) + cert V.empty - (WarpTLS.keyFile ts) + key + (isJust session) instance Default KeterConfig where def = KeterConfig @@ -165,6 +166,7 @@ type RequiresSecure = Bool data Stanza port = Stanza (StanzaRaw port) RequiresSecure + deriving Show data StanzaRaw port = StanzaStaticFiles !StaticFilesConfig @@ -235,6 +237,7 @@ -- FIXME basic auth , sfconfigMiddleware :: ![ MiddlewareConfig ] , sfconfigTimeout :: !(Maybe Int) + , sfconfigSsl :: !SSLConfig } deriving Show @@ -246,6 +249,7 @@ , sfconfigListings = True , sfconfigMiddleware = [] , sfconfigTimeout = Nothing + , sfconfigSsl = SSLFalse } instance ParseYamlFile StaticFilesConfig where @@ -255,6 +259,7 @@ <*> o .:? "directory-listing" .!= False <*> o .:? "middleware" .!= [] <*> o .:? "connection-time-bound" + <*> o .:? "ssl" .!= SSLFalse instance ToJSON StaticFilesConfig where toJSON StaticFilesConfig {..} = object @@ -263,12 +268,14 @@ , "directory-listing" .= sfconfigListings , "middleware" .= sfconfigMiddleware , "connection-time-bound" .= sfconfigTimeout + , "ssl" .= sfconfigSsl ] data RedirectConfig = RedirectConfig { redirconfigHosts :: !(Set Host) , redirconfigStatus :: !Int , redirconfigActions :: !(Vector RedirectAction) + , redirconfigSsl :: !SSLConfig } deriving Show @@ -279,6 +286,7 @@ , redirconfigStatus = 301 , redirconfigActions = V.singleton $ RedirectAction SPAny $ RDPrefix False (CI.mk to) Nothing + , redirconfigSsl = SSLFalse } instance ParseYamlFile RedirectConfig where @@ -286,12 +294,14 @@ <$> (Set.map CI.mk <$> ((o .: "hosts" <|> (Set.singleton <$> (o .: "host"))))) <*> o .:? "status" .!= 303 <*> o .: "actions" + <*> o .:? "ssl" .!= SSLFalse instance ToJSON RedirectConfig where toJSON RedirectConfig {..} = object [ "hosts" .= Set.map CI.original redirconfigHosts , "status" .= redirconfigStatus , "actions" .= redirconfigActions + , "ssl" .= redirconfigSsl ] data RedirectAction = RedirectAction !SourcePath !RedirectDest @@ -341,47 +351,6 @@ 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) @@ -391,7 +360,11 @@ , waconfigSsl :: !SSLConfig , waconfigPort :: !port , waconfigForwardEnv :: !(Set Text) + -- | how long are connections supposed to last , waconfigTimeout :: !(Maybe Int) + -- | how long in microseconds the app gets before we expect it to bind to + -- a port (default 90 seconds) + , waconfigEnsureAliveTimeout :: !(Maybe Int) } deriving Show @@ -407,6 +380,7 @@ , waconfigPort = () , waconfigForwardEnv = Set.empty , waconfigTimeout = Nothing + , waconfigEnsureAliveTimeout = Nothing } instance ParseYamlFile (WebAppConfig ()) where @@ -430,6 +404,7 @@ <*> return () <*> o .:? "forward-env" .!= Set.empty <*> o .:? "connection-time-bound" + <*> o .:? "ensure-alive-time-bound" instance ToJSON (WebAppConfig ()) where toJSON WebAppConfig {..} = object @@ -444,6 +419,7 @@ data AppInput = AIBundle !FilePath !EpochTime | AIData !BundleConfig + deriving Show data BackgroundConfig = BackgroundConfig { bgconfigExec :: !F.FilePath 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 @@ -30,6 +30,7 @@ import Blaze.ByteString.Builder (fromByteString) +import Keter.Types.Common -- Configuration files import Data.Default @@ -41,6 +42,7 @@ -- Reverse proxy apparatus import qualified Network.Wai as Wai +import qualified Network.Wai.Internal as I import Network.HTTP.Client.Conduit import qualified Network.HTTP.Client as NHC import Network.HTTP.Types @@ -126,7 +128,7 @@ , NHC.responseTimeout = reverseTimeout rpConfig #endif , method = Wai.requestMethod request - , secure = reverseUseSSL rpConfig + , secure = reversedUseSSL rpConfig , host = encodeUtf8 $ reversedHost rpConfig , port = reversedPort rpConfig , path = Wai.rawPathInfo request @@ -134,11 +136,12 @@ , requestHeaders = filterHeaders $ rewriteHeaders reqRuleMap (Wai.requestHeaders request) , requestBody = case Wai.requestBodyLength request of - Wai.ChunkedBody -> RequestBodyStreamChunked ($ Wai.requestBody request) - Wai.KnownLength n -> RequestBodyStream (fromIntegral n) ($ Wai.requestBody request) + Wai.ChunkedBody -> RequestBodyStreamChunked ($ I.getRequestBodyChunk request) + Wai.KnownLength n -> RequestBodyStream (fromIntegral n) ($ I.getRequestBodyChunk request) , decompress = const False , redirectCount = 0 , cookieJar = Nothing + , requestVersion = Wai.httpVersion request } where reqRuleMap = mkRuleMap $ rewriteRequestRules rpConfig @@ -163,8 +166,9 @@ data ReverseProxyConfig = ReverseProxyConfig { reversedHost :: Text , reversedPort :: Int + , reversedUseSSL :: Bool , reversingHost :: Text - , reverseUseSSL :: Bool + , reversingUseSSL :: !SSLConfig , reverseTimeout :: Maybe Int , rewriteResponseRules :: Set RewriteRule , rewriteRequestRules :: Set RewriteRule @@ -174,8 +178,9 @@ parseJSON (Object o) = ReverseProxyConfig <$> o .: "reversed-host" <*> o .: "reversed-port" + <*> o .: "reversed-ssl" .!= False <*> o .: "reversing-host" - <*> o .:? "ssl" .!= False + <*> o .:? "ssl" .!= SSLFalse <*> o .:? "timeout" .!= Nothing <*> o .:? "rewrite-response" .!= Set.empty <*> o .:? "rewrite-request" .!= Set.empty @@ -185,8 +190,9 @@ toJSON ReverseProxyConfig {..} = object [ "reversed-host" .= reversedHost , "reversed-port" .= reversedPort + , "reversed-ssl" .= reversedUseSSL , "reversing-host" .= reversingHost - , "ssl" .= reverseUseSSL + , "ssl" .= reversingUseSSL , "timeout" .= reverseTimeout , "rewrite-response" .= rewriteResponseRules , "rewrite-request" .= rewriteRequestRules @@ -196,8 +202,9 @@ def = ReverseProxyConfig { reversedHost = "" , reversedPort = 80 + , reversedUseSSL = False , reversingHost = "" - , reverseUseSSL = False + , reversingUseSSL = SSLFalse , reverseTimeout = Nothing , rewriteResponseRules = Set.empty , rewriteRequestRules = Set.empty diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,13 @@ +[![Build Status](https://travis-ci.com/idcm/keter.svg?branch=modernize)](https://travis-ci.com/idcm/keter) + + Deployment system for web applications, originally intended for hosting Yesod applications. Keter does the following actions for your application: * Binds to the main port (usually port 80) and reverse proxies requests to your application based on virtual hostnames. * Provides SSL support if requested. * Automatically launches applications, monitors processes, and relaunches any processes which die. -* Provides graceful redeployment support, by launching a second copy of your application, performing a health check, and then switching reverse proxying to the new process. +* Provides graceful redeployment support, by launching a second copy of your application, performing a health check[1], and then switching reverse proxying to the new process. * Management of log files. Keter provides many more advanced features and extension points. It allows @@ -12,12 +15,17 @@ databases, and more. It supports a simple bundle format for applications which allows for easy management of your web apps. +[1]: The health check happens trough checking if a port is opened. + If your app doesn't open a port after 30 seconds it's presumed + not healthy and gets a term signal. + ## Quick Start -To get Keter up-and-running quickly on an Ubuntu system, run: +To get Keter up-and-running quickly for development purposes, on an Ubuntu system (not on your production server), run: wget -O - https://raw.githubusercontent.com/snoyberg/keter/master/setup-keter.sh | bash +(Note: This assumes you already have keter installed via cabal.) (Note: you may need to run the above command twice, if the shell exits after `apt-get` but before running the rest of its instructions.) This will download and build Keter from source and get it running with a @@ -37,9 +45,10 @@ 1. Modify your web app to check for the `PORT` environment variable, and have it listen for incoming HTTP requests on that port. Keter automatically - assigns arbitrary ports to each web app it manages. The Yesod scaffold - site is already equipped to read the `PORT` environment variable when - it is set. + assigns arbitrary ports to each web app it manages. When building an app + based on the Yesod Scaffold, it may be necessary to change the `port` + variable in `config/settings.yaml` from `YESOD_PORT` to `PORT` for + compatibility with Keter. 2. Create a file `config/keter.yaml`. The minimal file just has two settings: @@ -59,14 +68,18 @@ directory for file updates, and automatically redeploy new versions of your bundle. +Examples are available in the [incoming](https://github.com/snoyberg/keter/tree/master/incoming) +directory. + ## Setup -Instructions are for an Ubuntu system. Eventually, I hope to provide a PPA for -this (please contact me if you would like to assist with this). For now, the -following steps should be sufficient: +### Building keter for Debian, Ubuntu and derivatives -First, install PostgreSQL +Eventually, I hope to provide a PPA for this (please contact me if you would +like to assist with this). For now, the following steps should be sufficient: +First, install PostgreSQL: + sudo apt-get install postgresql Second, build the `keter` binary and place it at `/opt/keter/bin`. To do so, @@ -82,9 +95,67 @@ Third, create a Keter config file. You can view a sample at https://github.com/snoyberg/keter/blob/master/etc/keter-config.yaml. -Fourth, set up an Upstart job to start `keter` when your system boots. +Optionally, you may wish to change the owner on the `/opt/keter/incoming` +folder to your user account, so that you can deploy without `sudo`ing. + sudo mkdir -p /opt/keter/incoming + sudo chown $USER /opt/keter/incoming + +### Building keter for Redhat and derivatives (Centos, Fedora, etc) + +First, install PostgreSQL: + + sudo dnf install postgresql + +Second, build the `keter` binary and place it at `/opt/keter/bin`. To do so, +you'll need to install the Haskell Platform, and can then build with `cabal`. +This would look something like: + + sudo dnf install haskell-platform + cabal update + cabal install keter + sudo mkdir -p /opt/keter/bin + sudo cp ~/.cabal/bin/keter /opt/keter/bin + +Third, create a Keter config file. You can view a sample at +https://github.com/snoyberg/keter/blob/master/etc/keter-config.yaml. + +### Configuring startup + +For versions of Ubuntu and derivatives 15.04 or greater and Redhat and derivatives (Centos, Fedora, etc) use systemd + ``` +# /etc/systemd/system/keter.service +[Unit] +Description=Keter +After=network.service + +[Service] +Type=simple +ExecStart=/opt/keter/bin/keter /opt/keter/etc/keter-config.yaml + +[Install] +WantedBy=multi-user.target +``` + +Finally, enable and start the unit (Note: You may need to disable SELinux): + + sudo systemctl enable keter + sudo systemctl start keter + +Verify that it's actually running with: + + sudo systemctl status keter + +Optionally, you may wish to change the owner on the `/opt/keter/incoming` +folder to your user account, so that you can deploy without `sudo`ing. + + sudo mkdir -p /opt/keter/incoming + sudo chown $USER /opt/keter/incoming +--- +For versions of Ubuntu and derivatives less than 15.04, configure an Upstart job. + +``` # /etc/init/keter.conf start on (net-device-up and local-filesystems and runlevel [2345]) stop on runlevel [016] @@ -101,11 +172,6 @@ sudo start keter -Optionally, you may wish to change the owner on the `/opt/keter/incoming` -folder to your user account, so that you can deploy without `sudo`ing. - - sudo mkdir -p /opt/keter/incoming - sudo chown $USER /opt/keter/incoming ## Bundles diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -1,5 +1,6 @@ +Cabal-version: >=1.10 Name: keter -Version: 1.4.3.2 +Version: 1.5 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/ @@ -9,7 +10,6 @@ Maintainer: michael@snoyman.com Category: Web, Yesod Build-type: Simple -Cabal-version: >=1.8 extra-source-files: ChangeLog.md README.md @@ -20,13 +20,15 @@ default: False Library + default-language: Haskell98 Build-depends: base >= 4 && < 5 , directory + , fsnotify >= 0.3 , bytestring , text , containers , transformers - , process + , process >= 1.4.3 && < 1.7 , random , data-default , filepath @@ -36,15 +38,15 @@ , tar >= 0.4 , template-haskell , blaze-builder >= 0.3 && < 0.5 - , yaml >= 0.8.4 && < 0.9 - , unix-compat >= 0.3 && < 0.5 + , yaml >= 0.8.4 && < 0.12 + , unix-compat >= 0.3 && < 0.6 , conduit >= 1.1 , conduit-extra >= 1.1 - , http-reverse-proxy >= 0.4.2 && < 0.5 + , http-reverse-proxy >= 0.4.2 && < 0.7 , unix >= 2.5 , wai-app-static >= 3.1 && < 3.2 - , wai >= 3.0 && < 3.3 - , wai-extra >= 3.0.3 && < 3.1 + , wai >= 3.2.2 + , wai-extra >= 3.0.3 && < 3.2 , http-types , regex-tdfa >= 1.1 , attoparsec >= 0.10 @@ -54,23 +56,22 @@ , array , mtl , warp - , warp-tls >= 3.0.3 + , warp-tls >= 3.0.3 && < 3.4.0 , aeson , unordered-containers , vector , stm >= 2.4 , async , lifted-base - , tls >= 1.3.4 + , tls >= 1.4 + , tls-session-manager if impl(ghc < 7.6) build-depends: ghc-prim if flag(system-filepath) - build-depends: fsnotify >= 0.1 && < 0.2 - , system-filepath + build-depends: + system-filepath cpp-options: -DSYSTEM_FILEPATH - else - build-depends: fsnotify >= 0.2.0.2 Exposed-Modules: Keter.Plugin.Postgres Keter.Types @@ -94,6 +95,7 @@ c-sources: cbits/process-tracker.c Executable keter + default-language: Haskell98 Main-is: keter.hs hs-source-dirs: main Build-depends: base, keter, data-default, filepath @@ -101,6 +103,7 @@ other-modules: Paths_keter test-suite test + default-language: Haskell98 hs-source-dirs: test main-is: Spec.hs type: exitcode-stdio-1.0