angel 0.5.0 → 0.5.1
raw patch · 11 files changed
+401/−265 lines, 11 files
Files
- README.md +23/−30
- angel.cabal +7/−46
- src/Angel/Config.hs +74/−49
- src/Angel/Data.hs +30/−18
- src/Angel/Files.hs +6/−6
- src/Angel/Job.hs +132/−72
- src/Angel/Log.hs +5/−1
- src/Angel/Main.hs +37/−21
- src/Angel/PidFile.hs +26/−16
- src/Angel/Process.hs +53/−0
- src/Angel/Util.hs +8/−6
README.md view
@@ -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: <program-id>`.-+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 ---
angel.cabal view
@@ -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 <michael@michaelxavier.net>- 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
src/Angel/Config.hs view
@@ -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
src/Angel/Data.hs view
@@ -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
src/Angel/Files.hs view
@@ -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
src/Angel/Job.hs view
@@ -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
src/Angel/Log.hs view
@@ -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' ++ " -"
src/Angel/Main.hs view
@@ -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
src/Angel/PidFile.hs view
@@ -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'
+ src/Angel/Process.hs view
@@ -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
src/Angel/Util.hs view
@@ -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