keter 1.4.3.2 → 1.5
raw patch · 15 files changed
+363/−158 lines, 15 filesdep +tls-session-managerdep ~fsnotifydep ~http-reverse-proxydep ~processnew-uploader
Dependencies added: tls-session-manager
Dependency ranges changed: fsnotify, http-reverse-proxy, process, tls, unix-compat, wai, wai-extra, warp-tls, yaml
Files
- ChangeLog.md +11/−0
- Data/Conduit/Process/Unix.hs +10/−5
- Keter/App.hs +71/−33
- Keter/AppManager.hs +3/−0
- Keter/Main.hs +8/−5
- Keter/PortPool.hs +20/−4
- Keter/Proxy.hs +37/−11
- Keter/Types.hs +0/−1
- Keter/Types/Common.hs +55/−2
- Keter/Types/Middleware.hs +0/−1
- Keter/Types/V04.hs +8/−8
- Keter/Types/V10.hs +28/−52
- Network/HTTP/ReverseProxy/Rewrite.hs +14/−7
- README.md +81/−15
- keter.cabal +17/−14
ChangeLog.md view
@@ -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.
Data/Conduit/Process/Unix.hs view
@@ -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
Keter/App.hs view
@@ -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
Keter/AppManager.hs view
@@ -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
Keter/Main.hs view
@@ -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
Keter/PortPool.hs view
@@ -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
Keter/Proxy.hs view
@@ -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) =
Keter/Types.hs view
@@ -22,6 +22,5 @@ , BackgroundConfig (..) , RestartCount (..) , RequiresSecure- , SSLConfig (..) ) import Network.HTTP.ReverseProxy.Rewrite as X (ReverseProxyConfig (..), RewriteRule (..))
Keter/Types/Common.hs view
@@ -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
Keter/Types/Middleware.hs view
@@ -9,7 +9,6 @@ import Control.Monad import Control.Arrow ((***))-import Control.Applicative -- various Middlewares import Network.Wai.Middleware.AcceptOverride (acceptOverride)
Keter/Types/V04.hs view
@@ -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: <http://www.yesodweb.com/book/settings-types>.
Keter/Types/V10.hs view
@@ -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
Network/HTTP/ReverseProxy/Rewrite.hs view
@@ -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
README.md view
@@ -1,10 +1,13 @@+[](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
keter.cabal view
@@ -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: <http://www.stackage.org/package/keter>. 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