diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -88,34 +88,6 @@ * I have not tried building `angel` against ghc 6.10 or earlier; 6.12, 7.0, 7.2, 7.4, and 7.6 are known to work -Testing -------- -If you prefer to stick with haskell tools, use cabal to build the package. - -If you have Ruby installed, I've set up a Rakefile for assisting in the -build/testing/sandboxing/dependency process. This isn't necessary to build or -test Angel, but it makes it easier. Run: - -``` -gem install bundler # if you don't have it already -bundle install -rake --tasks -``` - -If you're using cabal 0.17 or later, and I suggest you do, run - -``` -rake sandbox -``` -Run the full test suite with -``` -rake test -``` - -You can also use `guard start` which will watch for changes made to any source/test -files and re-run the tests for a rapid feedback cycle. - - Configuration and Usage Example ------------------------------- @@ -138,6 +110,7 @@ stdout = "/tmp/ls_log" stderr = "/tmp/ls_log" delay = 7 + termgrace = off } workers { @@ -149,6 +122,7 @@ FOO = "BAR" BAR = "BAZ" } + termgrace = 10 } Each program that should be supervised starts a `program-id` block: @@ -183,9 +157,17 @@ created. If you don't specify an absolute path, it will use the running directory of angel. When combined with the `count` option, specifying a pidfile of `worker.pid`, it will generate `worker-1.pid`, `worker-2.pid`, - etc. + etc. If you don't specify a `pidfile` directive, then `angel` will *not* + create a pidfile * `env` is a nested config of string key/value pairs. Non-string values are invalid. + * `termgrace` is an optional number of seconds to wait between + sending a SIGTERM and a SIGKILL to a program when it needs to shut + down. Any positive number will be interpreted as seconds. `0`, + `off`, or omission will be interpreted as disabling the feature and + only a sigterm will be sent. This is useful for processes that must + not be brought down forcefully to avoid corruption of data or other + ill effects. Assuming the above configuration was in a file called "example.conf", here's what a shell session might look like: @@ -212,7 +194,7 @@ notices that two programs need to be started. A supervisor is started in a lightweight thread for each, and starts logging with the context `program: `. - +pp `watch-date` starts up and runs. Since `watch` is a long-running process it just keeps running in the background. @@ -261,6 +243,17 @@ of configuration files and host-based or service-based environment variables, efficient, templated `angel` configurations can be had. + +Testing +------- +If you prefer to stick with haskell tools, use cabal to build the package. + + +You can run the test suite with + +``` +make test +``` FAQ --- diff --git a/angel.cabal b/angel.cabal --- a/angel.cabal +++ b/angel.cabal @@ -1,32 +1,9 @@ --- angel.cabal auto-generated by cabal init. For additional --- options, see --- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. --- The name of the package. Name: angel - --- The package version. See the Haskell package versioning policy --- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for --- standards guiding when and how versions should be incremented. -Version: 0.5.0 - --- A short (one-line) description of the package. --- Synopsis: - --- A longer description of the package. --- Description: - --- The license under which the package is released. +Version: 0.5.1 License: BSD3 - --- The file containing the license text. License-file: LICENSE - --- The package author(s). Author: Jamie Turner - --- Synopsos Synopsis: Process management and supervision daemon - Description: @angel@ is a daemon that runs and monitors other processes. It is similar to djb's `daemontools` or the Ruby project `god`. . @@ -35,25 +12,15 @@ See the homepage for documentation. --- An email address to which users can send suggestions, bug reports, --- and patches. Maintainer: Michael Xavier - Homepage: http://github.com/MichaelXavier/Angel --- A copyright notice. --- Copyright: - --- Stability of the pakcage (experimental, provisional, stable...) Stability: Stable Category: System Build-type: Simple --- Extra files to be distributed with the package, such as examples or --- a README. Extra-source-files: README.md --- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.8 @@ -62,13 +29,10 @@ location: https://github.com/MichaelXavier/Angel.git Executable angel - -- .hs or .lhs file containing the Main module. Hs-Source-Dirs: src Main-is: Angel/Main.hs - - -- Packages needed in order to build this package. + Build-depends: base >= 4.0 && < 5 - -- binding to the internals of process here, gotta be careful Build-depends: process >= 1.2.0.0 && < 2.0 Build-depends: mtl Build-depends: configurator >= 0.1 @@ -80,22 +44,18 @@ Build-depends: old-locale Build-depends: text>=0.11 - - -- Modules not exported by this package. + Other-modules: Angel.Files, Angel.Config, Angel.Data, - Angel.Files, Angel.Job, + Angel.Process Angel.Log, - Angel.Util + Angel.Util, Angel.PidFile - - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. - -- Build-tools: Extensions: OverloadedStrings,ScopedTypeVariables,BangPatterns,ViewPatterns - + Ghc-Options: -threaded -fwarn-missing-import-lists test-suite spec @@ -116,3 +76,4 @@ Build-depends: old-locale Build-depends: text>=0.11 Extensions: OverloadedStrings,ScopedTypeVariables,BangPatterns,ViewPatterns + Ghc-Options: -threaded -rtsopts -with-rtsopts=-N diff --git a/src/Angel/Config.hs b/src/Angel/Config.hs --- a/src/Angel/Config.hs +++ b/src/Angel/Config.hs @@ -1,10 +1,11 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} module Angel.Config ( monitorConfig , modifyProg - , expandByCount ) where + , expandByCount + -- for testing + , processConfig) where import Control.Exception ( try , SomeException ) @@ -19,10 +20,12 @@ import Data.Configurator ( load , getMap , Worth(Required) ) -import Data.Configurator.Types ( Value(Number, String) +import Data.Configurator.Types ( Value(Number, String, Bool) , Name ) import qualified Data.Traversable as T import qualified Data.HashMap.Lazy as HM +import Data.List ( nub + , foldl' ) import Data.Maybe ( isNothing , isJust ) import Data.Monoid ( (<>) ) @@ -36,85 +39,104 @@ , pidFile , workingDir , name + , termGrace , env ) , SpecKey - , GroupConfig(..) + , GroupConfig + , spec , defaultProgram ) import Angel.Log ( logger ) import Angel.Util ( waitForWake , nnull , expandPath ) -void :: Monad m => m a -> m () -void m = m >> return () - -- |produce a mapping of name -> program for every program -buildConfigMap :: HM.HashMap Name Value -> IO SpecKey -buildConfigMap cfg = do - return $! HM.foldlWithKey' addToMap M.empty cfg +buildConfigMap :: HM.HashMap Name Value -> SpecKey +buildConfigMap = HM.foldlWithKey' addToMap M.empty . addDefaults where addToMap :: SpecKey -> Name -> Value -> SpecKey - addToMap m name value - | nnull basekey && nnull localkey = + addToMap m n value + | nnull basekey && nnull localkey = let !newprog = case M.lookup basekey m of Just prog -> modifyProg prog localkey value Nothing -> modifyProg defaultProgram {name = basekey, env = []} localkey value in M.insert basekey newprog m | otherwise = m - where (basekey, '.':localkey) = break (== '.') $ T.unpack name + where (basekey, '.':localkey) = break (== '.') $ T.unpack n +addDefaults :: HM.HashMap Name Value -> HM.HashMap Name Value +addDefaults conf = foldl' addDefault conf progs + where + graceKey prog = prog <> ".grace" + progs = programNames conf + addDefault conf' prog + | HM.member (graceKey prog) conf' = conf' + | otherwise = HM.insert (graceKey prog) defaultGrace conf + defaultGrace = Bool False + +programNames :: HM.HashMap Name a -> [Name] +programNames = nub . filter nnullN . map extractName . HM.keys + where + extractName = T.takeWhile (/= '.') + checkConfigValues :: SpecKey -> IO SpecKey -checkConfigValues progs = (mapM_ checkProgram $ M.elems progs) >> (return progs) +checkConfigValues progs = mapM_ checkProgram (M.elems progs) >> return progs where checkProgram p = do when (isNothing $ exec p) $ error $ name p ++ " does not have an 'exec' specification" - when ((isJust $ logExec p) && + when (isJust (logExec p) && (isJust (stdout p) || isJust (stderr p) )) $ error $ name p ++ " cannot have both a logger process and stderr/stdout" modifyProg :: Program -> String -> Value -> Program -modifyProg prog "exec" (String s) = prog{exec = Just (T.unpack s)} -modifyProg prog "exec" _ = error "wrong type for field 'exec'; string required" +modifyProg prog "exec" (String s) = prog {exec = Just (T.unpack s)} +modifyProg _ "exec" _ = error "wrong type for field 'exec'; string required" modifyProg prog "delay" (Number n) | n < 0 = error "delay value must be >= 0" | otherwise = prog{delay = Just $ round n} -modifyProg prog "delay" _ = error "wrong type for field 'delay'; integer" +modifyProg _ "delay" _ = error "wrong type for field 'delay'; integer" modifyProg prog "stdout" (String s) = prog{stdout = Just (T.unpack s)} -modifyProg prog "stdout" _ = error "wrong type for field 'stdout'; string required" +modifyProg _ "stdout" _ = error "wrong type for field 'stdout'; string required" modifyProg prog "stderr" (String s) = prog{stderr = Just (T.unpack s)} -modifyProg prog "stderr" _ = error "wrong type for field 'stderr'; string required" +modifyProg _ "stderr" _ = error "wrong type for field 'stderr'; string required" -modifyProg prog "directory" (String s) = prog{workingDir = (Just $ T.unpack s)} -modifyProg prog "directory" _ = error "wrong type for field 'directory'; string required" +modifyProg prog "directory" (String s) = prog{workingDir = Just (T.unpack s)} +modifyProg _ "directory" _ = error "wrong type for field 'directory'; string required" -modifyProg prog "logger" (String s) = prog{logExec = (Just $ T.unpack s)} -modifyProg prog "logger" _ = error "wrong type for field 'logger'; string required" +modifyProg prog "logger" (String s) = prog{logExec = Just (T.unpack s)} +modifyProg _ "logger" _ = error "wrong type for field 'logger'; string required" -modifyProg prog "pidfile" (String s) = prog{pidFile = (Just $ T.unpack s)} -modifyProg prog "pidfile" _ = error "wrong type for field 'pidfile'; string required" +modifyProg prog "pidfile" (String s) = prog{pidFile = Just (T.unpack s)} +modifyProg _ "pidfile" _ = error "wrong type for field 'pidfile'; string required" modifyProg prog ('e':'n':'v':'.':envVar) (String s) = prog{env = envVar'} - where envVar' = (envVar, T.unpack s):(env prog) -modifyProg prog ('e':'n':'v':'.':_) _ = error "wrong type for env field; string required" + where envVar' = (envVar, T.unpack s):env prog +modifyProg _ ('e':'n':'v':'.':_) _ = error "wrong type for env field; string required" -modifyProg prog n _ = prog +modifyProg prog "termgrace" (Bool False) = prog{termGrace = Nothing} +modifyProg prog "termgrace" (Number n) | n < 0 = error "termgrace if it is a number must be >= 1" + | n == 0 = prog{termGrace = Nothing} + | otherwise = prog { termGrace = Just $ round n} +modifyProg _ "termgrace" _ = error "wrong type for field 'temgrace'; number or boolean false required" +modifyProg prog _ _ = prog + -- |invoke the parser to process the file at configPath -- |produce a SpecKey processConfig :: String -> IO (Either String SpecKey) -processConfig configPath = do +processConfig configPath = do mconf <- try $ process =<< load [Required configPath] case mconf of Right config -> return $ Right config Left (e :: SomeException) -> return $ Left $ show e - where process = getMap >=> - return . expandByCount >=> - buildConfigMap >=> - expandPaths >=> + where process = getMap >=> + return . expandByCount >=> + return . buildConfigMap >=> + expandPaths >=> checkConfigValues -- |preprocess config into multiple programs if "count" is specified @@ -151,36 +173,36 @@ rewritePidfile x = x textNumber :: Rational -> T.Text -textNumber = T.pack . show . truncate +textNumber = T.pack . show . (truncate :: Rational -> Integer) reflatten :: Name -> HM.HashMap Name Value -> HM.HashMap Name Value reflatten prog pcfg = HM.fromList asList where asList = map prependKey $ filter notCount $ HM.toList pcfg - prependKey (k, v) = ((prog <> "." <> k), v) + prependKey (k, v) = (prog <> "." <> k, v) notCount = not . (== "count") . fst --- |given a new SpecKey just parsed from the file, update the +-- |given a new SpecKey just parsed from the file, update the -- |shared state TVar updateSpecConfig :: TVar GroupConfig -> SpecKey -> STM () -updateSpecConfig sharedGroupConfig spec = do +updateSpecConfig sharedGroupConfig newSpec = do cfg <- readTVar sharedGroupConfig - writeTVar sharedGroupConfig cfg{spec=spec} + writeTVar sharedGroupConfig cfg{spec=newSpec} --- |read the config file, update shared state with current spec, +-- |read the config file, update shared state with current spec, -- |re-sync running supervisors, wait for the HUP TVar, then repeat! monitorConfig :: String -> TVar GroupConfig -> TVar (Maybe Int) -> IO () -monitorConfig configPath sharedGroupConfig wakeSig = do - let log = logger "config-monitor" +monitorConfig configPath sharedGroupConfig wakeSig = do + let logger' = logger "config-monitor" mspec <- processConfig configPath - case mspec of - Left e -> do - log $ " <<<< Config Error >>>>\n" ++ e - log " <<<< Config Error: Skipping reload >>>>" - Right spec -> do - atomically $ updateSpecConfig sharedGroupConfig spec + case mspec of + Left e -> do + logger' $ " <<<< Config Error >>>>\n" ++ e + logger' " <<<< Config Error: Skipping reload >>>>" + Right newSpec -> do + atomically $ updateSpecConfig sharedGroupConfig newSpec syncSupervisors sharedGroupConfig waitForWake wakeSig - log "HUP caught, reloading config" + logger' "HUP caught, reloading config" expandPaths :: SpecKey -> IO SpecKey expandPaths = T.mapM expandProgramPaths @@ -197,3 +219,6 @@ workingDir = workingDir', pidFile = pidFile' } where maybeExpand = T.traverse expandPath + +nnullN :: Name -> Bool +nnullN = not . T.null diff --git a/src/Angel/Data.hs b/src/Angel/Data.hs --- a/src/Angel/Data.hs +++ b/src/Angel/Data.hs @@ -4,7 +4,9 @@ , ProgramId , FileRequest , Program(..) + , RunState(..) , Spec + , KillDirective(..) , defaultProgram , defaultDelay , defaultStdout @@ -12,13 +14,7 @@ ) where import qualified Data.Map as M -import System.Process ( createProcess - , proc - , waitForProcess - , ProcessHandle ) -import System.Process ( terminateProcess - , CreateProcess(..) - , StdStream(..) ) +import System.Process ( ProcessHandle ) import Control.Concurrent.STM.TChan (TChan) import System.IO (Handle) @@ -32,31 +28,47 @@ -- |map program ids to relevant structure type SpecKey = M.Map ProgramId Program -type RunKey = M.Map ProgramId (Program, Maybe ProcessHandle) +type RunKey = M.Map ProgramId RunState + +data RunState = RunState { + rsProgram :: Program, + rsHandle :: Maybe ProcessHandle, + rsLogHandle :: Maybe ProcessHandle +} + type ProgramId = String type FileRequest = (String, TChan (Maybe Handle)) -- |the representation of a program is these 6 values, -- |read from the config file data Program = Program { - name :: String, - exec :: Maybe String, - delay :: Maybe Int, - stdout :: Maybe String, - stderr :: Maybe String, - workingDir :: Maybe FilePath, - logExec :: Maybe String, - pidFile :: Maybe FilePath, - env :: [(String, String)] + name :: String, + exec :: Maybe String, + delay :: Maybe Int, + stdout :: Maybe String, + stderr :: Maybe String, + workingDir :: Maybe FilePath, + logExec :: Maybe String, + pidFile :: Maybe FilePath, + env :: [(String, String)], + termGrace :: Maybe Int -- ^ How long to wait after sending a SIGTERM before SIGKILL. Nothing = never SIGKILL. Default Nothing } deriving (Show, Eq, Ord) +-- |represents all the data needed to handle terminating a process +data KillDirective = SoftKill String ProcessHandle (Maybe ProcessHandle) | + HardKill String ProcessHandle (Maybe ProcessHandle) Int + +-- instance Show KillDirective where +-- show (SoftKill _) = "SoftKill" +-- show (HardKill _ grace) = "HardKill after " ++ show grace ++ "s" + -- |Lower-level atoms in the configuration process type Spec = [Program] -- |a template for an empty program; the variable set to "" -- |are required, and must be overridden in the config file defaultProgram :: Program -defaultProgram = Program "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] +defaultProgram = Program "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing defaultDelay :: Int defaultDelay = 5 diff --git a/src/Angel/Files.hs b/src/Angel/Files.hs --- a/src/Angel/Files.hs +++ b/src/Angel/Files.hs @@ -8,17 +8,18 @@ , writeTChan , atomically , TChan - , newTChan , newTChanIO ) import Control.Monad (forever) import System.IO ( Handle , hClose , openFile - , IOMode(..) ) + , IOMode(AppendMode) ) import GHC.IO.Handle (hDuplicate) -import Angel.Data ( GroupConfig(..) +import Angel.Data ( GroupConfig + , fileRequest , FileRequest ) +startFileManager :: TChan FileRequest -> IO b startFileManager req = forever $ fileManager req fileManager :: TChan FileRequest -> IO () @@ -30,7 +31,7 @@ hand' <- hDuplicate hand hClose hand atomically $ writeTChan resp (Just hand') - Left (e :: SomeException) -> atomically $ writeTChan resp Nothing + Left (_ :: SomeException) -> atomically $ writeTChan resp Nothing fileManager req getFile :: String -> GroupConfig -> IO Handle @@ -38,7 +39,6 @@ resp <- newTChanIO atomically $ writeTChan (fileRequest cfg) (path, resp) mh <- atomically $ readTChan resp - hand <- case mh of + case mh of Just hand -> return hand Nothing -> error $ "could not open stdout/stderr file " ++ path - return hand diff --git a/src/Angel/Job.hs b/src/Angel/Job.hs --- a/src/Angel/Job.hs +++ b/src/Angel/Job.hs @@ -1,26 +1,33 @@ module Angel.Job ( syncSupervisors + , killProcess -- for testing , pollStale ) where import Control.Exception ( finally ) +import Control.Monad ( unless + , when + , forever) import Data.Maybe ( mapMaybe , fromMaybe , fromJust ) import System.Process ( createProcess , proc , waitForProcess - , ProcessHandle ) -import System.Process ( terminateProcess - , CreateProcess(..) - , StdStream(..) ) + , ProcessHandle + , CreateProcess + , std_out + , std_err + , std_in + , cwd + , env + , StdStream(UseHandle, CreatePipe) ) import Control.Concurrent ( forkIO ) import Control.Concurrent.STM ( TVar , writeTVar , readTVar , atomically ) import qualified Data.Map as M -import Control.Monad ( when - , forever ) -import Angel.Log ( logger ) +import Angel.Log ( logger + , programLogger ) import Angel.Data ( Program( delay , exec , logExec @@ -28,13 +35,21 @@ , pidFile , stderr , stdout + , termGrace , workingDir ) , ProgramId - , GroupConfig(..) + , GroupConfig + , spec + , running + , KillDirective(SoftKill, HardKill) + , RunState(..) , defaultProgram , defaultDelay , defaultStdout , defaultStderr ) +import Angel.Process ( isProcessHandleDead + , softKillProcessHandle + , hardKillProcessHandle ) import qualified Angel.Data as D import Angel.Util ( sleepSecs , strip @@ -46,23 +61,25 @@ ifEmpty :: String -> IO () -> IO () -> IO () ifEmpty s ioa iob = if s == "" then ioa else iob + -- |launch the program specified by `id`, opening (and closing) the -- |appropriate fds for logging. When the process dies, either b/c it was -- |killed by a monitor, killed by a system user, or ended execution naturally, -- |re-examine the desired run config to determine whether to re-run it. if so, -- |tail call. -supervise sharedGroupConfig id = do - log "START" +supervise :: TVar GroupConfig -> String -> IO () +supervise sharedGroupConfig id' = do + logger' "START" cfg <- atomically $ readTVar sharedGroupConfig let my_spec = find_me cfg - ifEmpty (name my_spec) + ifEmpty (name my_spec) - (log "QUIT (missing from config on restart)") - + (logger' "QUIT (missing from config on restart)") + (do - (attachOut, attachErr) <- makeFiles my_spec cfg + (attachOut, attachErr, lHandle) <- makeFiles my_spec cfg - let (cmd, args) = cmdSplit $ (fromJust $ exec my_spec) + let (cmd, args) = cmdSplit . fromJust . exec $ my_spec let procSpec = (proc cmd args) { std_out = attachOut, @@ -72,44 +89,44 @@ } let mPfile = pidFile my_spec - - log $ "Spawning process with env " ++ show (env procSpec) + let onPidError lph ph = do logger' "Failed to create pidfile" + killProcess $ toKillDirective my_spec ph lph - - startMaybeWithPidFile procSpec mPfile $ \pHandle -> do - updateRunningPid my_spec (Just pHandle) - log "RUNNING" - waitForProcess pHandle - log "ENDED" - updateRunningPid my_spec (Nothing) - - cfg <- atomically $ readTVar sharedGroupConfig - if M.notMember id (spec cfg) + logger' $ "Spawning process with env " ++ show (env procSpec) - then do - log "QUIT" + startMaybeWithPidFile procSpec mPfile (\pHandle -> do + updateRunningPid my_spec (Just pHandle) lHandle + logProcess logger' pHandle + updateRunningPid my_spec Nothing Nothing) (onPidError lHandle) - else do - log "WAITING" - sleepSecs $ (fromMaybe defaultDelay $ delay my_spec) - log "RESTART" - supervise sharedGroupConfig id + cfg' <- atomically $ readTVar sharedGroupConfig + if M.notMember id' (spec cfg') + then logger' "QUIT" + else do + logger' "WAITING" + sleepSecs . fromMaybe defaultDelay . delay $ my_spec + logger' "RESTART" + supervise sharedGroupConfig id' ) - + where - log = logger $ "- program: " ++ id ++ " -" - cmdSplit fullcmd = (head parts, tail parts) + logger' = programLogger id' + cmdSplit fullcmd = (head parts, tail parts) where parts = (filter (/="") . map strip . split ' ') fullcmd - find_me cfg = M.findWithDefault defaultProgram id (spec cfg) - updateRunningPid my_spec mpid = atomically $ do + find_me cfg = M.findWithDefault defaultProgram id' (spec cfg) + updateRunningPid my_spec mpid mlpid = atomically $ do wcfg <- readTVar sharedGroupConfig + let rstate = RunState { rsProgram = my_spec + , rsHandle = mpid + , rsLogHandle = mlpid + } writeTVar sharedGroupConfig wcfg{ - running=M.insertWith' (\n o-> n) id (my_spec, mpid) (running wcfg) + running=M.insertWith' const id' rstate (running wcfg) } - - makeFiles my_spec cfg = do - case (logExec my_spec) of + + makeFiles my_spec cfg = + case logExec my_spec of Just path -> logWithExec path Nothing -> logWithFiles @@ -121,75 +138,113 @@ let useerr = fromMaybe defaultStderr $ stderr my_spec attachErr <- UseHandle `fmap` getFile useerr cfg - return $ (attachOut, attachErr) + return (attachOut, attachErr, Nothing) logWithExec path = do let (cmd, args) = cmdSplit path - + attachOut <- UseHandle `fmap` getFile "/dev/null" cfg - log "Spawning process" - (inPipe, _, _, p) <- createProcess (proc cmd args){ + logger' "Spawning logger process" + (inPipe, _, _, logpHandle) <- createProcess (proc cmd args){ std_out = attachOut, std_err = attachOut, std_in = CreatePipe, cwd = workingDir my_spec } - return $ (UseHandle (fromJust inPipe), - UseHandle (fromJust inPipe)) + forkIO $ logProcess logExecLogger logpHandle --- |send a TERM signal to all provided process handles -killProcesses :: [ProcessHandle] -> IO () -killProcesses pids = mapM_ terminateProcess pids + return (UseHandle (fromJust inPipe), + UseHandle (fromJust inPipe), + Just logpHandle) + where + logExecLogger = programLogger $ "logger for " ++ id' +logProcess :: (String -> IO ()) -> ProcessHandle -> IO () +logProcess logSink pHandle = do + logSink "RUNNING" + waitForProcess pHandle + logSink "ENDED" + +--TODO: paralellize +killProcesses :: [KillDirective] -> IO () +killProcesses = mapM_ killProcess + +killProcess :: KillDirective -> IO () +killProcess (SoftKill n pid lpid) = do + logger' $ "Soft killing " ++ n + softKillProcessHandle pid + case lpid of + Just lph -> killProcess (SoftKill n lph Nothing) + Nothing -> return () + where logger' = logger "process-killer" +killProcess (HardKill n pid lpid grace) = do + logger' $ "Attempting soft kill " ++ n ++ " before hard killing" + softKillProcessHandle pid + logger' $ "Waiting " ++ show grace ++ " seconds for " ++ n ++ " to die" + sleepSecs grace + + -- Note that this means future calls to get exits status will fail + dead <- isProcessHandleDead pid + + unless dead $ logger' ("Hard killing " ++ n) >> hardKillProcessHandle pid + case lpid of + Just lph -> killProcess (HardKill n lph Nothing grace) + Nothing -> return () + where logger' = logger "process-killer" + cleanPidfiles :: [Program] -> IO () cleanPidfiles progs = mapM_ clearPIDFile pidfiles where pidfiles = mapMaybe pidFile progs -- |fire up new supervisors for new program ids startProcesses :: TVar GroupConfig -> [String] -> IO () -startProcesses sharedGroupConfig starts = mapM_ spawnWatcher starts +startProcesses sharedGroupConfig = mapM_ spawnWatcher where spawnWatcher s = forkIO $ wrapProcess sharedGroupConfig s wrapProcess :: TVar GroupConfig -> String -> IO () -wrapProcess sharedGroupConfig id = do +wrapProcess sharedGroupConfig id' = do run <- createRunningEntry - when run $ finally (supervise sharedGroupConfig id) deleteRunning + when run $ finally (supervise sharedGroupConfig id') deleteRunning where - deleteRunning = atomically $ do + deleteRunning = atomically $ do wcfg <- readTVar sharedGroupConfig writeTVar sharedGroupConfig wcfg{ - running=M.delete id (running wcfg) + running=M.delete id' (running wcfg) } createRunningEntry = atomically $ do cfg <- readTVar sharedGroupConfig - let specmap = spec cfg - case M.lookup id specmap of + let specmap = spec cfg + case M.lookup id' specmap of Nothing -> return False Just target -> do let runmap = running cfg - case M.lookup id runmap of + case M.lookup id' runmap of Just _ -> return False Nothing -> do + let rstate = RunState { rsProgram = target + , rsHandle = Nothing + , rsLogHandle = Nothing + } writeTVar sharedGroupConfig cfg{running= - M.insert id (target, Nothing) runmap} + M.insert id' rstate runmap} return True -- |diff the requested config against the actual run state, and -- |do any start/kill action necessary syncSupervisors :: TVar GroupConfig -> IO () -syncSupervisors sharedGroupConfig = do - let log = logger "process-monitor" +syncSupervisors sharedGroupConfig = do + let logger' = logger "process-monitor" cfg <- atomically $ readTVar sharedGroupConfig let (killProgs, killHandles) = mustKill cfg let starts = mustStart cfg - when (nnull killHandles || nnull starts) $ log ( - "Must kill=" ++ (show $ length killHandles) - ++ ", must start=" ++ (show $ length starts)) + when (nnull killHandles || nnull starts) $ logger' ( + "Must kill=" ++ show (length killHandles) + ++ ", must start=" ++ show (length starts)) killProcesses killHandles cleanPidfiles killProgs startProcesses sharedGroupConfig starts @@ -197,19 +252,24 @@ --TODO: make private mustStart :: GroupConfig -> [String] mustStart cfg = map fst $ filter (isNew $ running cfg) $ M.assocs (spec cfg) - where isNew running (id, pg) = M.notMember id running + where isNew isRunning (id', _) = M.notMember id' isRunning --TODO: make private -mustKill :: GroupConfig -> ([Program], [ProcessHandle]) +mustKill :: GroupConfig -> ([Program], [KillDirective]) mustKill cfg = unzip targets - where runningAndDifferent :: (ProgramId, (Program, Maybe ProcessHandle)) -> Maybe (Program, ProcessHandle) - runningAndDifferent (id, (pg, Nothing)) = Nothing - runningAndDifferent (id, (pg, (Just pid))) - | (M.notMember id specMap || M.findWithDefault defaultProgram id specMap /= pg) = Just (pg, pid) + where runningAndDifferent :: (ProgramId, RunState) -> Maybe (Program, KillDirective) + runningAndDifferent (_, RunState {rsHandle = Nothing}) = Nothing + runningAndDifferent (id', RunState {rsProgram = pg, rsHandle = Just pid, rsLogHandle = lpid}) + | M.notMember id' specMap || M.findWithDefault defaultProgram id' specMap /= pg = Just (pg, toKillDirective pg pid lpid) | otherwise = Nothing targets = mapMaybe runningAndDifferent allRunning specMap = spec cfg allRunning = M.assocs $ running cfg + +toKillDirective :: Program -> ProcessHandle -> Maybe ProcessHandle -> KillDirective +toKillDirective D.Program { name = n + , termGrace = Just g } ph lph = HardKill n ph lph g +toKillDirective D.Program { name = n } ph lph = SoftKill n ph lph -- |periodically run the supervisor sync independent of config reload, -- |just in case state gets funky b/c of theoretically possible timing diff --git a/src/Angel/Log.hs b/src/Angel/Log.hs --- a/src/Angel/Log.hs +++ b/src/Angel/Log.hs @@ -1,5 +1,6 @@ module Angel.Log ( cleanCalendar - , logger) where + , logger + , programLogger ) where import Data.Time.LocalTime (ZonedTime, getZonedTime) @@ -18,3 +19,6 @@ logger lname msg = do zt <- getZonedTime printf "[%s] {%s} %s\n" (cleanCalendar zt) lname msg + +programLogger :: String -> (String -> IO ()) +programLogger id' = logger $ "- program: " ++ id' ++ " -" diff --git a/src/Angel/Main.hs b/src/Angel/Main.hs --- a/src/Angel/Main.hs +++ b/src/Angel/Main.hs @@ -1,23 +1,39 @@ -module Main (main) where +module Main (main) where -import Control.Concurrent (threadDelay, forkIO, forkOS) -import Control.Concurrent -import Control.Concurrent.MVar (newEmptyMVar, MVar, takeMVar, putMVar) -import Control.Concurrent.STM -import Control.Concurrent.STM.TVar (readTVar, writeTVar) -import Control.Concurrent.STM.TChan (newTChan) -import Control.Monad (unless, when, forever) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, + MVar, + takeMVar, + putMVar) +import Control.Concurrent.STM (TVar, + atomically, + writeTVar, + newTChan, + readTVar, + newTVarIO) +import Control.Monad (forever) import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.Posix.Signals -import System.IO (hSetBuffering, hPutStrLn, BufferMode(..), stdout, stderr) +import System.Exit (exitFailure, + exitSuccess) +import System.Posix.Signals (installHandler, + sigHUP, + sigTERM, + sigINT, + Handler(Catch)) +import System.IO (hSetBuffering, + hPutStrLn, + BufferMode(LineBuffering), + stdout, + stderr) import qualified Data.Map as M import Angel.Log (logger) import Angel.Config (monitorConfig) -import Angel.Data (GroupConfig(..)) -import Angel.Job (pollStale, syncSupervisors) +import Angel.Data (GroupConfig(GroupConfig), + spec) +import Angel.Job (pollStale, + syncSupervisors) import Angel.Files (startFileManager) -- |Signal handler: when a HUP is trapped, write to the wakeSig Tvar @@ -45,14 +61,14 @@ runWithConfigPath configPath = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering - let log = logger "main" - log "Angel started" + let logger' = logger "main" + logger' "Angel started" - log $ "Using config file: " ++ configPath + logger' $ "Using config file: " ++ configPath -- Create the TVar that represents the "global state" of running applications -- and applications that _should_ be running - fileReqChan <- atomically $ newTChan + fileReqChan <- atomically newTChan sharedGroupConfig <- newTVarIO $ GroupConfig M.empty M.empty fileReqChan -- The wake signal, set by the HUP handler to wake the monitor loop @@ -72,14 +88,14 @@ forkIO $ forever $ monitorConfig configPath sharedGroupConfig wakeSig _ <- takeMVar bye - log "INT | TERM received; initiating shutdown..." - log " 1. Clearing config" + logger' "INT | TERM received; initiating shutdown..." + logger' " 1. Clearing config" atomically $ do cfg <- readTVar sharedGroupConfig writeTVar sharedGroupConfig cfg {spec = M.empty} - log " 2. Forcing sync to kill running going" + logger' " 2. Forcing sync to kill running processes" syncSupervisors sharedGroupConfig - log "That's all folks!" + logger' "That's all folks!" errorExit :: String -> IO () errorExit msg = hPutStrLn stderr msg >> exitFailure diff --git a/src/Angel/PidFile.hs b/src/Angel/PidFile.hs --- a/src/Angel/PidFile.hs +++ b/src/Angel/PidFile.hs @@ -2,11 +2,9 @@ , startWithPidFile , clearPIDFile) where -import Control.Applicative ( (<$>) - , (<*>) ) -import Control.Exception.Base ( catch - , finally - , SomeException) +import Control.Exception.Base ( finally + , onException ) + import Control.Monad (when) import System.Process ( CreateProcess , createProcess @@ -14,23 +12,36 @@ -- Wish I didn't have to do this :( import System.Process.Internals ( PHANDLE - , ProcessHandle__(..) + , ProcessHandle__(OpenHandle, ClosedHandle) , withProcessHandle ) import System.Posix.Files ( removeLink , fileExist) -startMaybeWithPidFile :: CreateProcess -> Maybe FilePath -> (ProcessHandle -> IO a) -> IO a -startMaybeWithPidFile procSpec (Just pidFile) = startWithPidFile procSpec pidFile -startMaybeWithPidFile procSpec Nothing = withPHandle procSpec +startMaybeWithPidFile :: CreateProcess + -> Maybe FilePath + -> (ProcessHandle -> IO a) + -> (ProcessHandle -> IO a) + -> IO a +startMaybeWithPidFile procSpec (Just pidFile) action onPidError = startWithPidFile procSpec pidFile action onPidError +startMaybeWithPidFile procSpec Nothing action _ = withPHandle procSpec action -startWithPidFile :: CreateProcess -> FilePath -> (ProcessHandle -> IO a) -> IO a -startWithPidFile procSpec pidFile action = do +startWithPidFile :: CreateProcess + -> FilePath + -> (ProcessHandle -> IO a) + -> (ProcessHandle -> IO a) + -> IO a +startWithPidFile procSpec pidFile action onPidError = withPHandle procSpec $ \pHandle -> do mPid <- getPID pHandle - maybe (return ()) write mPid - action pHandle `finally` clearPIDFile pidFile - where write = writePID pidFile + case mPid of + Just pid -> write pid pHandle + Nothing -> proceed pHandle + where + write pid pHandle = do + writePID pidFile pid `onException` onPidError pHandle -- re-raises + proceed pHandle + proceed pHandle = action pHandle `finally` clearPIDFile pidFile withPHandle :: CreateProcess -> (ProcessHandle -> IO a) -> IO a withPHandle procSpec action = do @@ -43,8 +54,7 @@ clearPIDFile :: FilePath -> IO () clearPIDFile pidFile = do ex <- fileExist pidFile when ex rm - where exists = fileExist pidFile - rm = removeLink pidFile + where rm = removeLink pidFile getPID :: ProcessHandle -> IO (Maybe PHANDLE) getPID pHandle = withProcessHandle pHandle getPID' diff --git a/src/Angel/Process.hs b/src/Angel/Process.hs new file mode 100644 --- /dev/null +++ b/src/Angel/Process.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Angel.Process ( getProcessHandleStatus + , isProcessHandleDead + , softKillProcessHandle + , hardKillProcessHandle + , signalProcessHandle ) where + +import Control.Exception (catchJust) +import Control.Monad ( join + , void ) +import Data.Maybe (isJust) +import System.IO.Error ( catchIOError + , isDoesNotExistError) +import System.Process (ProcessHandle) +import System.Process.Internals ( ProcessHandle__(OpenHandle, ClosedHandle) + , withProcessHandle ) +import System.Posix.Types (ProcessID) +import System.Posix.Process ( ProcessStatus + , getProcessStatus ) +import System.Posix.Signals ( Signal + , sigTERM + , sigKILL + , signalProcess ) + +withPid :: (ProcessID -> IO a) -> ProcessHandle -> IO (Maybe a) +withPid action ph = withProcessHandle ph callback + where callback (ClosedHandle _) = return Nothing + callback (OpenHandle pid) = do res <- action pid + return (Just res) + +getProcessHandleStatus :: ProcessHandle -> IO (Maybe ProcessStatus) +getProcessHandleStatus ph = catchJust exPred getStatus handleDNE + where shouldBlock = False + includeStopped = True + getStatus = fmap join $ withPid (getProcessStatus shouldBlock includeStopped) ph + exPred e + | isDoesNotExistError e = Just () + | otherwise = Nothing + handleDNE = const $ return Nothing -- ehhhhhhhhhhhhh, Nothing means not available? + +signalProcessHandle :: Signal -> ProcessHandle -> IO () +signalProcessHandle sig = void . withPid (signalProcess sig) + +softKillProcessHandle :: ProcessHandle -> IO () +softKillProcessHandle = signalProcessHandle sigTERM + +hardKillProcessHandle :: ProcessHandle -> IO () +hardKillProcessHandle = signalProcessHandle sigKILL + +isProcessHandleDead :: ProcessHandle -> IO Bool +isProcessHandleDead ph = catchIOError checkHandle (const $ return True) + where + checkHandle = fmap isJust $ getProcessHandleStatus ph diff --git a/src/Angel/Util.hs b/src/Angel/Util.hs --- a/src/Angel/Util.hs +++ b/src/Angel/Util.hs @@ -6,10 +6,12 @@ , strip , nnull ) where -import Control.Concurrent -import Control.Concurrent.STM -import Control.Concurrent.STM.TVar (readTVar, writeTVar) -import Control.Concurrent (threadDelay, forkIO, forkOS) +import Control.Concurrent.STM (atomically + , retry + , TVar + , readTVar + , writeTVar) +import Control.Concurrent (threadDelay) import Data.Char (isSpace) import Data.Maybe (catMaybes) import System.Posix.User (getEffectiveUserName, @@ -22,10 +24,10 @@ -- |wait for the STM TVar to be non-nothing waitForWake :: TVar (Maybe Int) -> IO () -waitForWake wakeSig = atomically $ do +waitForWake wakeSig = atomically $ do state <- readTVar wakeSig case state of - Just x -> writeTVar wakeSig Nothing + Just _ -> writeTVar wakeSig Nothing Nothing -> retry expandPath :: FilePath -> IO FilePath