diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 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 @@ -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 () diff --git a/Keter/App.hs b/Keter/App.hs --- a/Keter/App.hs +++ b/Keter/App.hs @@ -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 diff --git a/Keter/AppManager.hs b/Keter/AppManager.hs --- a/Keter/AppManager.hs +++ b/Keter/AppManager.hs @@ -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 + diff --git a/Keter/Cli.hs b/Keter/Cli.hs new file mode 100644 --- /dev/null +++ b/Keter/Cli.hs @@ -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 diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -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. diff --git a/Keter/Types/Common.hs b/Keter/Types/Common.hs --- a/Keter/Types/Common.hs +++ b/Keter/Types/Common.hs @@ -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 diff --git a/Keter/Types/V10.hs b/Keter/Types/V10.hs --- a/Keter/Types/V10.hs +++ b/Keter/Types/V10.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[![Build Status](https://travis-ci.com/idcm/keter.svg?branch=modernize)](https://travis-ci.com/idcm/keter) +[![Githbu actions build status](https://img.shields.io/github/workflow/status/snoyberg/keter/Stack)](https://github.com/snoyberg/keter/actions) Deployment system for web applications, originally intended for hosting Yesod diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -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: . 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