keter 1.5 → 1.6
raw patch · 10 files changed
+245/−41 lines, 10 filesdep +indexed-traversabledep +optparse-applicative
Dependencies added: indexed-traversable, optparse-applicative
Files
- ChangeLog.md +9/−0
- Data/Conduit/Process/Unix.hs +21/−3
- Keter/App.hs +30/−10
- Keter/AppManager.hs +47/−19
- Keter/Cli.hs +95/−0
- Keter/Main.hs +12/−1
- Keter/Types/Common.hs +21/−6
- Keter/Types/V10.hs +5/−0
- README.md +1/−1
- keter.cabal +4/−1
ChangeLog.md view
@@ -1,3 +1,12 @@+## 1.6+* Make keter more chatty on boot.+ This allows you to figure out in code where things go wrong.+* Add opt-in debug CLI, allowing you to inspect keters' internal state.+ You can activate it by specifying a cli-port.+* Emit which pid is being killed by keter.+ This helps with process leakage issues,+ for example if the user launches from a bash script without using `exec`.+ ## 1.5 * Builds with `process` 1.6
Data/Conduit/Process/Unix.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+ module Data.Conduit.Process.Unix ( -- * Process tracking -- $processTracker@@ -16,16 +17,18 @@ , MonitoredProcess , monitorProcess , terminateMonitoredProcess+ , printStatus ) where -import Control.Applicative ((<$>), (<*>))+import Data.Text(Text, pack)+import Control.Applicative ((<$>), (<*>), pure) import Control.Arrow ((***)) import Control.Concurrent (forkIO) import Control.Concurrent (threadDelay) import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar,- takeMVar)+ takeMVar, tryReadMVar) import Control.Exception (Exception, SomeException, bracketOnError, finally, handle, mask_,@@ -56,9 +59,11 @@ import System.Posix.Types (CPid (..)) import System.Process (CmdSpec (..), CreateProcess (..), StdStream (..), createProcess,- terminateProcess, waitForProcess)+ terminateProcess, waitForProcess,+ getPid) import System.Process.Internals (ProcessHandle (..), ProcessHandle__ (..))+import Data.Monoid ((<>)) -- sauron processHandleMVar :: ProcessHandle -> MVar ProcessHandle__ #if MIN_VERSION_process(1, 6, 0)@@ -320,6 +325,19 @@ -- | Abstract type containing information on a process which will be restarted. newtype MonitoredProcess = MonitoredProcess (MVar Status)++printStatus :: MonitoredProcess -> IO Text+printStatus (MonitoredProcess mstatus) = do+ mStatus <- tryReadMVar mstatus+ case mStatus of+ Nothing -> pure "no status set process"+ Just NeedsRestart -> pure "needs-restart process"+ Just NoRestart -> pure "no-restart process"+ Just (Running running) -> do+ x <- getPid running+ case x of+ Just y -> pure ("running process '" <> pack (show y) <> "'")+ Nothing -> pure "just closed process" -- | Terminate the process and prevent it from being restarted. terminateMonitoredProcess :: MonitoredProcess -> IO ()
Keter/App.hs view
@@ -12,6 +12,7 @@ , reload , getTimestamp , Keter.App.terminate+ , showApp ) where import Codec.Archive.TempTarball@@ -27,8 +28,8 @@ import qualified Data.Conduit.LogFile as LogFile import Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker, monitorProcess,- terminateMonitoredProcess)-import Data.Foldable (for_)+ terminateMonitoredProcess, printStatus)+import Data.Foldable (for_, traverse_) import Data.IORef import qualified Data.Map as Map import Data.Maybe (fromMaybe)@@ -54,6 +55,7 @@ import System.Posix.Types (EpochTime, GroupID, UserID) import System.Timeout (timeout) import qualified Network.TLS as TLS+import qualified Data.Text.Encoding as Text data App = App { appModTime :: !(TVar (Maybe EpochTime))@@ -68,12 +70,26 @@ instance Show App where show App {appId, ..} = "App{appId=" <> show appId <> "}" +-- | within an stm context we can show a lot more then the show instance can do+showApp :: App -> STM Text+showApp App{..} = do+ appModTime' <- readTVar appModTime+ appRunning' <- readTVar appRunningWebApps+ appHosts' <- readTVar appHosts+ pure $ pack $+ (show appId) <>+ " modtime: " <> (show appModTime') <> ", webappsRunning: " <> show appRunning' <> ", hosts: " <> show appHosts'++ data RunningWebApp = RunningWebApp { rwaProcess :: !MonitoredProcess , rwaPort :: !Port , rwaEnsureAliveTimeOut :: !Int } +instance Show RunningWebApp where+ show (RunningWebApp {..}) = "RunningWebApp{rwaPort=" <> show rwaPort <> ", rwaEnsureAliveTimeOut=" <> show rwaEnsureAliveTimeOut <> ",..}"+ newtype RunningBackgroundApp = RunningBackgroundApp { rbaProcess :: MonitoredProcess }@@ -330,8 +346,10 @@ AIBuiltin -> "__builtin__" AINamed x -> x -killWebApp :: RunningWebApp -> IO ()-killWebApp RunningWebApp {..} = do+killWebApp :: (LogMessage -> IO ()) -> RunningWebApp -> IO ()+killWebApp asclog RunningWebApp {..} = do+ status <- printStatus rwaProcess+ asclog $ KillingApp rwaPort status terminateMonitoredProcess rwaProcess ensureAlive :: RunningWebApp -> IO ()@@ -583,18 +601,19 @@ withWebApps appAsc appId bconfig newdir rlog webapps $ \runningWebapps -> do mapM_ ensureAlive runningWebapps readTVarIO appHosts >>= reactivateApp (ascLog appAsc) (ascHostManager appAsc) appId actions- (oldApps, oldBacks, oldDir) <- atomically $ do+ (oldApps, oldBacks, oldDir, oldRlog) <- atomically $ do oldApps <- readTVar appRunningWebApps oldBacks <- readTVar appBackgroundApps oldDir <- readTVar appDir+ oldRlog <- readTVar appRlog writeTVar appModTime mmodtime writeTVar appRunningWebApps runningWebapps writeTVar appBackgroundApps runningBacks writeTVar appHosts $ Map.keysSet actions writeTVar appDir newdir- return (oldApps, oldBacks, oldDir)- void $ forkIO $ terminateHelper appAsc appId oldApps oldBacks oldDir+ return (oldApps, oldBacks, oldDir, oldRlog)+ void $ forkIO $ terminateHelper appAsc appId oldApps oldBacks oldDir oldRlog terminate :: App -> IO () terminate App {..} = do@@ -615,7 +634,7 @@ return (hosts, apps, backs, mdir, rlog) deactivateApp ascLog ascHostManager appId hosts- void $ forkIO $ terminateHelper appAsc appId apps backs mdir+ void $ forkIO $ terminateHelper appAsc appId apps backs mdir rlog maybe (return ()) LogFile.close rlog where AppStartConfig {..} = appAsc@@ -625,11 +644,12 @@ -> [RunningWebApp] -> [RunningBackgroundApp] -> Maybe FilePath+ -> Maybe RotatingLog -> IO ()-terminateHelper AppStartConfig {..} aid apps backs mdir = do+terminateHelper AppStartConfig {..} aid apps backs mdir rlog = do threadDelay $ 20 * 1000 * 1000 ascLog $ TerminatingOldProcess aid- mapM_ killWebApp apps+ mapM_ (killWebApp ascLog) apps mapM_ killBackgroundApp backs threadDelay $ 60 * 1000 * 1000 case mdir of
Keter/AppManager.hs view
@@ -13,24 +13,31 @@ , terminateApp -- * Initialize , initialize+ -- * Show+ , renderApps ) where import Control.Applicative-import Control.Concurrent (forkIO)-import Control.Concurrent.MVar (MVar, newMVar, withMVar)+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (MVar, newMVar, withMVar) import Control.Concurrent.STM-import qualified Control.Exception as E-import Control.Monad (void)-import qualified Data.Map as Map-import Data.Maybe (mapMaybe)-import Data.Maybe (catMaybes)-import qualified Data.Set as Set-import Keter.App (App, AppStartConfig)-import qualified Keter.App as App+import qualified Control.Exception as E+import Control.Monad (void)+import Data.Foldable (fold)+import qualified Data.Map as Map+import Data.Maybe (catMaybes, mapMaybe)+import qualified Data.Set as Set+import Data.Text (pack, unpack)+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as Builder+import Data.Traversable.WithIndex (itraverse)+import Keter.App (App, AppStartConfig, showApp)+import qualified Keter.App as App import Keter.Types-import Prelude hiding (FilePath, log)-import System.Posix.Files (getFileStatus, modificationTime)-import System.Posix.Types (EpochTime)+import Prelude hiding (FilePath, log)+import System.Posix.Files (getFileStatus, modificationTime)+import System.Posix.Types (EpochTime)+import Text.Printf (printf) data AppManager = AppManager { apps :: !(TVar (Map AppId (TVar AppState)))@@ -46,7 +53,27 @@ !(TVar (Maybe Action)) -- ^ the next one to try | ASTerminated +showAppState :: AppState -> STM Text+showAppState (ASRunning x) = (\x -> "running(" <> x <> ")") <$> showApp x+showAppState (ASStarting mapp tmtime tmaction) = do+ mtime <- readTVar tmtime+ maction <- readTVar tmaction+ mtext <- traverse showApp mapp+ pure $ pack $ printf "starting app %s, time %s, action %s \n" (unpack $ fold mtext) (show mtime) (show maction)+showAppState ASTerminated = pure "terminated"++renderApps :: AppManager -> STM Text+renderApps mngr = do+ appMap <- readTVar $ apps mngr+ x <- itraverse (\appId tappState -> do+ state <- readTVar tappState+ res <- showAppState state+ pure $ Builder.fromText $ res <> " \n"+ ) appMap+ pure $ LT.toStrict $ Builder.toLazyText $ fold x+ data Action = Reload AppInput | Terminate+ deriving Show initialize :: (LogMessage -> IO ()) -> AppStartConfig@@ -75,7 +102,7 @@ fmap catMaybes $ mapM (getAction m) allApps sequence_ actions where- toAppName AIBuiltin = Nothing+ toAppName AIBuiltin = Nothing toAppName (AINamed x) = Just x getAction currentApps appname = do@@ -106,7 +133,7 @@ where freshLaunch = case Map.lookup appname newApps of- Nothing -> E.assert False Nothing+ Nothing -> E.assert False Nothing Just (fp, timestamp) -> reload fp timestamp terminate = Just $ performNoLock am (AINamed appname) Terminate reload fp timestamp = Just $ performNoLock am (AINamed appname) (Reload $ AIBundle fp timestamp)@@ -175,7 +202,7 @@ tmtimestamp <- newTVar $ case input of AIBundle _fp timestamp -> Just timestamp- AIData _ -> Nothing+ AIData _ -> Nothing tstate <- newTVar $ ASStarting Nothing tmtimestamp tmnext modifyTVar apps $ Map.insert aid tstate return $ launchWorker am aid tstate tmnext Nothing action@@ -205,12 +232,12 @@ tmtimestamp <- newTVar $ case action of Reload (AIBundle _fp timestamp) -> Just timestamp- Reload (AIData _) -> Nothing- Terminate -> Nothing+ Reload (AIData _) -> Nothing+ Terminate -> Nothing writeTVar tstate $ ASStarting mRunningApp tmtimestamp tmnext return mnext case mnext of- Nothing -> return ()+ Nothing -> return () Just next -> loop mRunningApp next processAction Nothing Terminate = return Nothing@@ -254,3 +281,4 @@ terminateApp :: AppManager -> Appname -> IO () terminateApp appMan appname = perform appMan (AINamed appname) Terminate+
+ Keter/Cli.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}+module Keter.Cli+ ( launchCli+ , CliStates(..)+ ) where++import Keter.Types.Common+import Keter.AppManager+import Control.Concurrent (forkFinally)+import qualified Control.Exception as E+import Control.Monad (unless, forever, void, when)+import qualified Data.ByteString as S+import Network.Socket+import Network.Socket.ByteString (recv, sendAll)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Options.Applicative+import Data.Foldable+import GHC.Conc++data Commands = CmdListRunningApps+ | CmdExit++data CliStates = MkCliStates+ { csAppManager :: !AppManager+ , csLog :: !(LogMessage -> IO ())+ , csPort :: !Port+ }++launchCli :: CliStates -> IO ()+launchCli states = void $ forkIO $ withSocketsDo $ do+ addr <- resolve $ show $ csPort states+ E.bracket (open addr) close $ \x -> do+ csLog states $ BindCli addr+ loop states x+commandParser :: Parser Commands+commandParser = hsubparser $+ fold [+ command "exit"+ (info (pure CmdExit)+ (progDesc "List all ports"))+ ,+ command "apps"+ (info (pure CmdListRunningApps)+ (progDesc "Exit the program"))+ ]++resolve :: ServiceName -> IO AddrInfo+resolve port = do+ let hints = defaultHints {+ addrFlags = [AI_PASSIVE]+ , addrSocketType = Stream+ }+ addr:_ <- getAddrInfo (Just hints) Nothing (Just port)+ return addr++open :: AddrInfo -> IO Socket+open addr = do+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ setSocketOption sock ReuseAddr 1+ -- If the prefork technique is not used,+ -- set CloseOnExec for the security reasons.+ withFdSocket sock $ setCloseOnExecIfNeeded+ bind sock (addrAddress addr)+ listen sock 10+ return sock++loop :: CliStates -> Socket -> IO b+loop states sock = forever $ do+ (conn, peer) <- accept sock+ csLog states $ ReceivedCliConnection peer+ void $ forkFinally (talk states conn) (\_ -> close conn)++listRunningApps :: CliStates -> Socket -> IO ()+listRunningApps states conn = do+ txt <- atomically $ renderApps $ csAppManager states+ sendAll conn $ T.encodeUtf8 txt <> "\n"++talk :: CliStates -> Socket -> IO ()+talk states conn = do+ msg <- recv conn 1024+ unless (S.null msg) $ do+ case T.decodeUtf8' msg of+ Left exception -> sendAll conn ("decode error: " <> T.encodeUtf8 (T.pack $ show exception))+ Right txt -> do+ let res = execParserPure defaultPrefs (info (commandParser <**> helper)+ (fullDesc <> header "server repl" <> progDesc (+ "repl for inspecting program state. You can connect to a socket and ask predefined questions")) ) (T.unpack <$> T.words txt)+ isLoop <- case res of+ (Success (CmdListRunningApps)) -> True <$ listRunningApps states conn+ (Success (CmdExit )) -> False <$ sendAll conn "bye\n"+ (CompletionInvoked x) -> True <$ sendAll conn "completion ignored \n"+ Failure failure ->+ True <$ sendAll conn (T.encodeUtf8 (T.pack $ fst $ renderFailure failure "") <> "\n")+ when isLoop $ talk states conn
Keter/Main.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+ module Keter.Main ( keter ) where@@ -54,14 +55,24 @@ import qualified Filesystem.Path as FP (FilePath) import Filesystem.Path.CurrentOS (encodeString) #endif-+import Keter.Cli keter :: FilePath -- ^ root directory or config file -> [FilePath -> IO Plugin] -> IO () keter input mkPlugins = withManagers input mkPlugins $ \kc hostman appMan log -> do+ log LaunchCli+ forM (kconfigCliPort kc) $ \port ->+ launchCli (MkCliStates+ { csAppManager = appMan+ , csLog = log+ , csPort = port+ })+ log LaunchInitial launchInitial kc appMan+ log StartWatching startWatching kc appMan log+ log StartListening startListening kc hostman -- | Load up Keter config.
Keter/Types/Common.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-} module Keter.Types.Common ( module Keter.Types.Common@@ -15,9 +15,9 @@ ) where import Control.Exception (Exception, SomeException)-import Data.Aeson (Object, FromJSON, ToJSON,- Value(Bool), (.=), (.!=), (.:?),- withObject, withBool, object)+import Data.Aeson (FromJSON, Object, ToJSON,+ Value (Bool), object, withBool,+ withObject, (.!=), (.:?), (.=)) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI, original) import Data.Map (Map)@@ -25,11 +25,12 @@ 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 Data.Yaml.FilePath import qualified Language.Haskell.TH.Syntax as TH+import Network.Socket (AddrInfo, SockAddr) import System.Exit (ExitCode) import System.FilePath (FilePath, takeBaseName) @@ -86,6 +87,13 @@ | WatchedFile Text FilePath | ReloadFrom (Maybe String) String | Terminating String+ | LaunchInitial+ | LaunchCli+ | StartWatching+ | StartListening+ | BindCli AddrInfo+ | ReceivedCliConnection SockAddr+ | KillingApp Port Text instance Show LogMessage where show (ProcessCreated f) = "Created process: " ++ f@@ -146,6 +154,13 @@ , ": " , fp ]+ show LaunchInitial = "Launching initial"+ show (KillingApp port txt) = "Killing " <> unpack txt <> " running on port: " <> show port+ show LaunchCli = "Launching cli"+ show StartWatching = "Started watching"+ show StartListening = "Started listening"+ show (BindCli addr) = "Bound cli to " <> show addr+ show (ReceivedCliConnection peer) = "CLI Connection from " <> show peer data KeterException = CannotParsePostgres FilePath | ExitCodeFailure FilePath ExitCode@@ -174,7 +189,7 @@ data AppId = AIBuiltin | AINamed !Appname deriving (Eq, Ord) instance Show AppId where- show AIBuiltin = "/builtin/"+ show AIBuiltin = "/builtin/" show (AINamed t) = unpack t data SSLConfig
Keter/Types/V10.hs view
@@ -103,6 +103,8 @@ -- ^ Environment variables to be passed to all apps. , kconfigConnectionTimeBound :: !Int -- ^ Maximum request time in milliseconds per connection.+ , kconfigCliPort :: !(Maybe Port)+ -- ^ Port for the cli to listen on } instance ToCurrent KeterConfig where@@ -118,6 +120,7 @@ , kconfigExternalHttpsPort = 443 , kconfigEnvironment = Map.empty , kconfigConnectionTimeBound = connectionTimeBound+ , kconfigCliPort = Nothing } where getSSL Nothing = V.empty@@ -141,6 +144,7 @@ , kconfigExternalHttpsPort = 443 , kconfigEnvironment = Map.empty , kconfigConnectionTimeBound = V04.fiveMinutes+ , kconfigCliPort = Nothing } instance ParseYamlFile KeterConfig where@@ -161,6 +165,7 @@ <*> o .:? "external-https-port" .!= 443 <*> o .:? "env" .!= Map.empty <*> o .:? "connection-time-bound" .!= V04.fiveMinutes+ <*> o .:? "cli-port" -- | Whether we should force redirect to HTTPS routes. type RequiresSecure = Bool
README.md view
@@ -1,4 +1,4 @@-[](https://travis-ci.com/idcm/keter)+[](https://github.com/snoyberg/keter/actions) Deployment system for web applications, originally intended for hosting Yesod
keter.cabal view
@@ -1,6 +1,6 @@ Cabal-version: >=1.10 Name: keter-Version: 1.5+Version: 1.6 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/@@ -65,6 +65,8 @@ , lifted-base , tls >= 1.4 , tls-session-manager+ , optparse-applicative+ , indexed-traversable if impl(ghc < 7.6) build-depends: ghc-prim@@ -82,6 +84,7 @@ Keter.App Keter.AppManager Keter.LabelMap+ Keter.Cli Keter.Main Keter.PortPool Keter.Proxy