angel 0.5.1 → 0.5.2
raw patch · 9 files changed
+333/−199 lines, 9 filesdep +optparse-applicativedep +transformers
Dependencies added: optparse-applicative, transformers
Files
- README.md +15/−22
- angel.cabal +6/−1
- changelog.md +23/−0
- src/Angel/Config.hs +16/−9
- src/Angel/Data.hs +35/−2
- src/Angel/Files.hs +3/−36
- src/Angel/Job.hs +153/−90
- src/Angel/Log.hs +16/−6
- src/Angel/Main.hs +66/−33
README.md view
@@ -91,9 +91,19 @@ Configuration and Usage Example ------------------------------- -The `angel` executable takes exactly one argument: a path to-an angel configuration file.+The `angel` executable takes a path to an angel configuration+file. + angel --help+ angel - Process management and supervision daemon++ Usage: angel CONFIG_FILE [-v VERBOSITY]++ Available options:+ -h,--help Show this help text+ -v VERBOSITY Verbosity from 0-2 (default: 2)++ `angel`'s configuration system is based on Bryan O'Sullivan's `configurator` package. A full description of the format can be found here: @@ -132,6 +142,8 @@ Then, a series of corresponding configuration commands follow: * `exec` is the exact command line to run (required)+ * `user` is the user the program will run as (optional, defaults to the+ user angel is launched as) * `stdout` is a path to a file where the program's standard output should be appended (optional, defaults to /dev/null) * `stderr` is a path to a file where the program's standard error@@ -279,27 +291,8 @@ CHANGELOG ----------### 0.5.0-* Drop depdendency on MissingH -### 0.4.4--* Add `env` option to config.-* Inject `ANGEL_PROCESS_NUMBER` environment variable into processes started- with `count`.--### 0.4.3--* Fix install failure from pidfile module not being accounted for.--### 0.4.2--* Add `pidfile` option to program spec to specify a pidfile location.--### 0.4.1--* Add `count` option to program spec to launch multiple instances of a program.-+See [changelog.md](changelog.md) Author ------
angel.cabal view
@@ -1,5 +1,5 @@ Name: angel-Version: 0.5.1+Version: 0.5.2 License: BSD3 License-file: LICENSE Author: Jamie Turner@@ -14,12 +14,14 @@ Maintainer: Michael Xavier <michael@michaelxavier.net> Homepage: http://github.com/MichaelXavier/Angel+Bug-Reports: http://github.com/MichaelXavier/Angel/issues Stability: Stable Category: System Build-type: Simple Extra-source-files: README.md+ changelog.md Cabal-version: >=1.8 @@ -43,6 +45,8 @@ Build-depends: time Build-depends: old-locale Build-depends: text>=0.11+ Build-depends: transformers+ Build-depends: optparse-applicative Other-modules: Angel.Files,@@ -75,5 +79,6 @@ Build-depends: time Build-depends: old-locale Build-depends: text>=0.11+ Build-depends: transformers Extensions: OverloadedStrings,ScopedTypeVariables,BangPatterns,ViewPatterns Ghc-Options: -threaded -rtsopts -with-rtsopts=-N
+ changelog.md view
@@ -0,0 +1,23 @@+0.5.2+* Add -v flag to executable++0.5.0+* Drop depdendency on MissingH++0.4.4++* Add `env` option to config.+* Inject `ANGEL_PROCESS_NUMBER` environment variable into processes started+ with `count`.++0.4.3++* Fix install failure from pidfile module not being accounted for.++0.4.2++* Add `pidfile` option to program spec to specify a pidfile location.++0.4.1++* Add `count` option to program spec to launch multiple instances of a program.
src/Angel/Config.hs view
@@ -12,6 +12,7 @@ import qualified Data.Map as M import Control.Monad ( when , (>=>) )+import Control.Monad.IO.Class import Control.Concurrent.STM ( STM , TVar , writeTVar@@ -31,7 +32,8 @@ import Data.Monoid ( (<>) ) import qualified Data.Text as T import Angel.Job ( syncSupervisors )-import Angel.Data ( Program( exec+import Angel.Data ( Program( user+ , exec , delay , stdout , stderr@@ -42,7 +44,9 @@ , termGrace , env ) , SpecKey+ , AngelM , GroupConfig+ , Verbosity(..) , spec , defaultProgram ) import Angel.Log ( logger )@@ -92,6 +96,9 @@ modifyProg prog "exec" (String s) = prog {exec = Just (T.unpack s)} modifyProg _ "exec" _ = error "wrong type for field 'exec'; string required" +modifyProg prog "user" (String s) = prog{user = Just (T.unpack s)}+modifyProg _ "user" _ = error "wrong type for field 'user'; string required"+ modifyProg prog "delay" (Number n) | n < 0 = error "delay value must be >= 0" | otherwise = prog{delay = Just $ round n} modifyProg _ "delay" _ = error "wrong type for field 'delay'; integer"@@ -119,7 +126,7 @@ 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 _ "termgrace" _ = error "wrong type for field 'termgrace'; number or boolean false required" modifyProg prog _ _ = prog @@ -190,19 +197,19 @@ -- |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 :: String -> TVar GroupConfig -> TVar (Maybe Int) -> AngelM () monitorConfig configPath sharedGroupConfig wakeSig = do let logger' = logger "config-monitor"- mspec <- processConfig configPath+ mspec <- liftIO $ processConfig configPath case mspec of Left e -> do- logger' $ " <<<< Config Error >>>>\n" ++ e- logger' " <<<< Config Error: Skipping reload >>>>"+ logger' V1 $ " <<<< Config Error >>>>\n" ++ e+ logger' V2 " <<<< Config Error: Skipping reload >>>>" Right newSpec -> do- atomically $ updateSpecConfig sharedGroupConfig newSpec+ liftIO $ atomically $ updateSpecConfig sharedGroupConfig newSpec syncSupervisors sharedGroupConfig- waitForWake wakeSig- logger' "HUP caught, reloading config"+ liftIO $ waitForWake wakeSig+ logger' V2 "HUP caught, reloading config" expandPaths :: SpecKey -> IO SpecKey expandPaths = T.mapM expandProgramPaths
src/Angel/Data.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Angel.Data ( GroupConfig(..) , SpecKey , RunKey@@ -7,14 +8,21 @@ , RunState(..) , Spec , KillDirective(..)+ , Verbosity(..)+ , Options(..)+ , AngelM(..) , defaultProgram , defaultDelay , defaultStdout , defaultStderr+ , runAngelM ) where import qualified Data.Map as M import System.Process ( ProcessHandle )+import Control.Applicative+import Control.Monad.IO.Class+import Control.Monad.Reader import Control.Concurrent.STM.TChan (TChan) import System.IO (Handle) @@ -39,11 +47,12 @@ type ProgramId = String type FileRequest = (String, TChan (Maybe Handle)) --- |the representation of a program is these 6 values, +-- |the representation of a program is these 6 values, -- |read from the config file data Program = Program { name :: String, exec :: Maybe String,+ user :: Maybe String, delay :: Maybe Int, stdout :: Maybe String, stderr :: Maybe String,@@ -65,10 +74,34 @@ -- |Lower-level atoms in the configuration process type Spec = [Program] ++data Verbosity = V0+ -- ^ Failures only+ | V1+ -- ^ Failures + program starts/stops+ | V2+ -- ^ Max verbosity. Default. Logs all of the above as well as state changes and other debugging info.+ deriving (Show, Eq, Ord)+++data Options = Options {+ configFile :: FilePath+ , verbosity :: Verbosity+ }+++newtype AngelM a = AngelM {+ unAngelM :: ReaderT Options IO a+ } deriving (Functor, Applicative, Monad, MonadReader Options, MonadIO)+++runAngelM :: Options -> AngelM a -> IO a+runAngelM o (AngelM f) = runReaderT f o+ -- |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 [] Nothing+defaultProgram = Program "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing defaultDelay :: Int defaultDelay = 5
src/Angel/Files.hs view
@@ -1,44 +1,11 @@ {-# LANGUAGE ScopedTypeVariables #-}-module Angel.Files ( getFile- , startFileManager ) where+module Angel.Files ( getFile ) where -import Control.Exception ( try- , SomeException )-import Control.Concurrent.STM ( readTChan- , writeTChan- , atomically- , TChan- , newTChanIO )-import Control.Monad (forever) import System.IO ( Handle- , hClose , openFile , IOMode(AppendMode) )-import GHC.IO.Handle (hDuplicate)-import Angel.Data ( GroupConfig- , fileRequest- , FileRequest ) -startFileManager :: TChan FileRequest -> IO b-startFileManager req = forever $ fileManager req--fileManager :: TChan FileRequest -> IO ()-fileManager req = do - (path, resp) <- atomically $ readTChan req- mh <- try $ openFile path AppendMode- case mh of- Right hand -> do- hand' <- hDuplicate hand- hClose hand- atomically $ writeTChan resp (Just hand')- Left (_ :: SomeException) -> atomically $ writeTChan resp Nothing- fileManager req+import Angel.Data ( GroupConfig ) getFile :: String -> GroupConfig -> IO Handle-getFile path cfg = do- resp <- newTChanIO- atomically $ writeTChan (fileRequest cfg) (path, resp)- mh <- atomically $ readTChan resp- case mh of- Just hand -> return hand- Nothing -> error $ "could not open stdout/stderr file " ++ path+getFile path _ = openFile path AppendMode
src/Angel/Job.hs view
@@ -2,10 +2,12 @@ , killProcess -- for testing , pollStale ) where +import Control.Applicative ((<$>)) import Control.Exception ( finally ) import Control.Monad ( unless , when- , forever)+ , forever )+import Control.Monad.Reader (ask) import Data.Maybe ( mapMaybe , fromMaybe , fromJust )@@ -20,11 +22,18 @@ , cwd , env , StdStream(UseHandle, CreatePipe) )+import qualified System.Posix.Process as P ( forkProcess+ , getProcessStatus )+import qualified System.Posix.User as U (setUserID,+ getUserEntryForName,+ UserEntry(userID) )+ import Control.Concurrent ( forkIO ) import Control.Concurrent.STM ( TVar , writeTVar , readTVar , atomically )+import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M import Angel.Log ( logger , programLogger )@@ -38,11 +47,14 @@ , termGrace , workingDir ) , ProgramId+ , AngelM , GroupConfig+ , runAngelM , spec , running , KillDirective(SoftKill, HardKill) , RunState(..)+ , Verbosity(..) , defaultProgram , defaultDelay , defaultStdout@@ -59,63 +71,64 @@ import Angel.PidFile ( startMaybeWithPidFile , clearPIDFile ) -ifEmpty :: String -> IO () -> IO () -> IO ()-ifEmpty s ioa iob = if s == "" then ioa else iob+ifEmpty :: String -> a -> a -> a+ifEmpty s a b = if s == "" then a else b --- |launch the program specified by `id`, opening (and closing) the+switchUser :: String -> IO ()+switchUser name = do+ userEntry <- U.getUserEntryForName name+ U.setUserID $ U.userID userEntry++-- |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 :: TVar GroupConfig -> String -> IO ()+supervise :: TVar GroupConfig -> String -> AngelM () supervise sharedGroupConfig id' = do- logger' "START"- cfg <- atomically $ readTVar sharedGroupConfig- let my_spec = find_me cfg- ifEmpty (name my_spec)-- (logger' "QUIT (missing from config on restart)")+ logger' V2 "START"+ cfg <- liftIO $ atomically $ readTVar sharedGroupConfig+ let my_spec = find_spec cfg id' + ifEmpty (name my_spec)+ (logger' V2 "QUIT (missing from config on restart)") (do- (attachOut, attachErr, lHandle) <- makeFiles my_spec cfg-- let (cmd, args) = cmdSplit . fromJust . exec $ my_spec-- let procSpec = (proc cmd args) {- std_out = attachOut,- std_err = attachErr,- cwd = workingDir my_spec,- env = Just $ D.env my_spec- }-- let mPfile = pidFile my_spec- let onPidError lph ph = do logger' "Failed to create pidfile"- killProcess $ toKillDirective my_spec ph lph-- logger' $ "Spawning process with env " ++ show (env procSpec)+ let+ logProcessSpawn Nothing = return ()+ logProcessSpawn (Just (cmd, args)) = do+ logger' V1 $ "Spawning process: " ++ cmd ++ " with env " ++ ((show . D.env) my_spec) ++ (maybe "" (" as user: " ++) (D.user my_spec))+ superviseSpawner my_spec cfg cmd args sharedGroupConfig id' onValidHandle (\a b c -> onPidError a b c) - startMaybeWithPidFile procSpec mPfile (\pHandle -> do- updateRunningPid my_spec (Just pHandle) lHandle- logProcess logger' pHandle- updateRunningPid my_spec Nothing Nothing) (onPidError lHandle)+ logProcessSpawn $ fmap (cmdSplit) (exec my_spec) - cfg' <- atomically $ readTVar sharedGroupConfig+ cfg' <- liftIO $ atomically $ readTVar sharedGroupConfig if M.notMember id' (spec cfg')- then logger' "QUIT"+ then logger' V2 "QUIT" else do- logger' "WAITING"- sleepSecs . fromMaybe defaultDelay . delay $ my_spec- logger' "RESTART"+ logger' V2 "WAITING"+ liftIO $ sleepSecs . fromMaybe defaultDelay . delay $ my_spec+ logger' V2 "RESTART" supervise sharedGroupConfig id' ) where logger' = programLogger id'++ onValidHandle a_spec lph ph = do+ updateRunningPid a_spec (Just ph) lph+ logProcess logger' ph -- This will not return until the process has exited+ updateRunningPid a_spec Nothing Nothing++ onPidError a_spec lph ph = do+ logger' V2 "Failed to create pidfile"+ killProcess $ toKillDirective a_spec ph lph+ 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 mlpid = atomically $ do+ find_spec cfg id' = M.findWithDefault defaultProgram id' (spec cfg)++ updateRunningPid my_spec mpid mlpid = liftIO $ atomically $ do wcfg <- readTVar sharedGroupConfig let rstate = RunState { rsProgram = my_spec , rsHandle = mpid@@ -125,70 +138,113 @@ running=M.insertWith' const id' rstate (running wcfg) } +superviseSpawner+ :: Program+ -> GroupConfig+ -> String+ -> [String]+ -> TVar GroupConfig+ -> String+ -> (Program -> Maybe ProcessHandle -> ProcessHandle -> AngelM ())+ -> (Program -> Maybe ProcessHandle -> ProcessHandle -> AngelM ())+ -> AngelM ()+superviseSpawner the_spec cfg cmd args sharedGroupConfig id' onValidHandleAction onPidErrorAction = do+ opts <- ask+ let io = runAngelM opts+ liftIO $ do+ angelPid <- P.forkProcess $ do+ maybe (return ()) switchUser (D.user the_spec)+ -- start the logger process or if non is configured+ -- use the files specified in the configuration+ (attachOut, attachErr, lHandle) <- io $ makeFiles the_spec cfg++ let+ procSpec = (proc cmd args) {+ std_out = attachOut,+ std_err = attachErr,+ cwd = workingDir the_spec,+ env = Just $ D.env the_spec+ }++ startMaybeWithPidFile procSpec+ (pidFile the_spec)+ (io . onValidHandleAction the_spec lHandle)+ (io . onPidErrorAction the_spec lHandle)++ P.getProcessStatus True True angelPid+ return ()++ where+ cmdSplit fullcmd = (head parts, tail parts)+ where parts = (filter (/="") . map strip . split ' ') fullcmd+ makeFiles my_spec cfg = case logExec my_spec of Just path -> logWithExec path- Nothing -> logWithFiles-- where- logWithFiles = do- let useout = fromMaybe defaultStdout $ stdout my_spec- attachOut <- UseHandle `fmap` getFile useout cfg+ Nothing -> liftIO logWithFiles+ where+ logWithFiles = do+ let useout = fromMaybe defaultStdout $ stdout the_spec+ attachOut <- UseHandle <$> getFile useout cfg - let useerr = fromMaybe defaultStderr $ stderr my_spec- attachErr <- UseHandle `fmap` getFile useerr cfg+ let useerr = fromMaybe defaultStderr $ stderr the_spec+ attachErr <- UseHandle <$> getFile useerr cfg - return (attachOut, attachErr, Nothing)+ return (attachOut, attachErr, Nothing) - logWithExec path = do- let (cmd, args) = cmdSplit path+ logWithExec path = do+ let (cmd, args) = cmdSplit path - attachOut <- UseHandle `fmap` getFile "/dev/null" cfg+ attachOut <- UseHandle <$> liftIO (getFile "/dev/null" cfg) - logger' "Spawning logger process"- (inPipe, _, _, logpHandle) <- createProcess (proc cmd args){- std_out = attachOut,- std_err = attachOut,- std_in = CreatePipe,- cwd = workingDir my_spec- }+ (programLogger id') V2 "Spawning logger process"+ opts <- ask+ liftIO $ do+ (inPipe, _, _, logpHandle) <- createProcess (proc cmd args){+ std_out = attachOut,+ std_err = attachOut,+ std_in = CreatePipe,+ cwd = workingDir my_spec+ } - forkIO $ logProcess logExecLogger logpHandle+ forkIO $ runAngelM opts $ logProcess (\v m -> loggerSink v m) logpHandle - return (UseHandle (fromJust inPipe),- UseHandle (fromJust inPipe),- Just logpHandle)- where- logExecLogger = programLogger $ "logger for " ++ id'+ return (UseHandle (fromJust inPipe),+ UseHandle (fromJust inPipe),+ Just logpHandle)+ where+ loggerSink = programLogger $ "logger for " ++ id' -logProcess :: (String -> IO ()) -> ProcessHandle -> IO ()+logProcess :: (Verbosity -> String -> AngelM ()) -> ProcessHandle -> AngelM () logProcess logSink pHandle = do- logSink "RUNNING"- waitForProcess pHandle- logSink "ENDED"+ logSink V2 "RUNNING"+ liftIO $ waitForProcess pHandle+ logSink V2 "ENDED" --TODO: paralellize-killProcesses :: [KillDirective] -> IO ()+killProcesses :: [KillDirective] -> AngelM () killProcesses = mapM_ killProcess -killProcess :: KillDirective -> IO ()+killProcess :: KillDirective -> AngelM () killProcess (SoftKill n pid lpid) = do- logger' $ "Soft killing " ++ n- softKillProcessHandle pid+ logger' V2 $ "Soft killing " ++ n+ liftIO $ 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+ logger' V2 $ "Attempting soft kill " ++ n ++ " before hard killing"+ liftIO $ softKillProcessHandle pid+ logger' V2 $ "Waiting " ++ show grace ++ " seconds for " ++ n ++ " to die"+ liftIO $ sleepSecs grace -- Note that this means future calls to get exits status will fail- dead <- isProcessHandleDead pid+ dead <- liftIO $ isProcessHandleDead pid - unless dead $ logger' ("Hard killing " ++ n) >> hardKillProcessHandle pid+ unless dead $ do+ logger' V2 ("Hard killing " ++ n)+ liftIO $ hardKillProcessHandle pid case lpid of Just lph -> killProcess (HardKill n lph Nothing grace) Nothing -> return ()@@ -199,17 +255,22 @@ where pidfiles = mapMaybe pidFile progs -- |fire up new supervisors for new program ids-startProcesses :: TVar GroupConfig -> [String] -> IO ()+startProcesses :: TVar GroupConfig -> [String] -> AngelM () startProcesses sharedGroupConfig = mapM_ spawnWatcher where- spawnWatcher s = forkIO $ wrapProcess sharedGroupConfig s+ spawnWatcher s = do+ opts <- ask+ liftIO $ forkIO $ runAngelM opts $ wrapProcess sharedGroupConfig s -wrapProcess :: TVar GroupConfig -> String -> IO ()+wrapProcess :: TVar GroupConfig -> String -> AngelM () wrapProcess sharedGroupConfig id' = do- run <- createRunningEntry- when run $ finally (supervise sharedGroupConfig id') deleteRunning+ opts <- ask+ liftIO $ do+ run <- createRunningEntry+ when run $+ (runAngelM opts $ supervise sharedGroupConfig id') `finally` deleteRunning where- deleteRunning = atomically $ do+ deleteRunning = liftIO $ atomically $ do wcfg <- readTVar sharedGroupConfig writeTVar sharedGroupConfig wcfg{ running=M.delete id' (running wcfg)@@ -236,17 +297,17 @@ -- |diff the requested config against the actual run state, and -- |do any start/kill action necessary-syncSupervisors :: TVar GroupConfig -> IO ()+syncSupervisors :: TVar GroupConfig -> AngelM () syncSupervisors sharedGroupConfig = do let logger' = logger "process-monitor"- cfg <- atomically $ readTVar sharedGroupConfig+ cfg <- liftIO $ atomically $ readTVar sharedGroupConfig let (killProgs, killHandles) = mustKill cfg let starts = mustStart cfg- when (nnull killHandles || nnull starts) $ logger' (+ when (nnull killHandles || nnull starts) $ logger' V2 ( "Must kill=" ++ show (length killHandles) ++ ", must start=" ++ show (length starts)) killProcesses killHandles- cleanPidfiles killProgs+ liftIO $ cleanPidfiles killProgs startProcesses sharedGroupConfig starts --TODO: make private@@ -258,7 +319,7 @@ mustKill :: GroupConfig -> ([Program], [KillDirective]) mustKill cfg = unzip targets where runningAndDifferent :: (ProgramId, RunState) -> Maybe (Program, KillDirective)- runningAndDifferent (_, RunState {rsHandle = Nothing}) = Nothing+ 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@@ -274,5 +335,7 @@ -- |periodically run the supervisor sync independent of config reload, -- |just in case state gets funky b/c of theoretically possible timing -- |issues on reload-pollStale :: TVar GroupConfig -> IO ()-pollStale sharedGroupConfig = forever $ sleepSecs 10 >> syncSupervisors sharedGroupConfig+pollStale :: TVar GroupConfig -> AngelM ()+pollStale sharedGroupConfig = forever $ do+ liftIO $ sleepSecs 10+ syncSupervisors sharedGroupConfig
src/Angel/Log.hs view
@@ -2,23 +2,33 @@ , logger , programLogger ) where +import Control.Monad.Reader import Data.Time.LocalTime (ZonedTime, getZonedTime) import Data.Time.Format (formatTime) import Text.Printf (printf) import System.Locale (defaultTimeLocale)+import Angel.Data -- |provide a clean, ISO-ish format for timestamps in logs cleanCalendar :: ZonedTime -> String cleanCalendar = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" --- |log a line to stdout; indented for use with partial application for +-- |log a line to stdout; indented for use with partial application for -- |"local log"-type macroing-logger :: String -> String -> IO ()-logger lname msg = do - zt <- getZonedTime- printf "[%s] {%s} %s\n" (cleanCalendar zt) lname msg+logger :: String -> Verbosity -> String -> AngelM ()+logger lname v msg = do+ chk <- shouldLog v+ when chk $ liftIO $ do+ zt <- getZonedTime+ printf "[%s] {%s} %s\n" (cleanCalendar zt) lname msg -programLogger :: String -> (String -> IO ())+programLogger :: String -> Verbosity -> String -> AngelM () programLogger id' = logger $ "- program: " ++ id' ++ " -"+++shouldLog :: Verbosity -> AngelM Bool+shouldLog v = do+ maxV <- asks verbosity+ return $ v <= maxV
src/Angel/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} module Main (main) where import Control.Concurrent (forkIO)@@ -12,6 +13,8 @@ readTVar, newTVarIO) import Control.Monad (forever)+import Control.Monad.Reader+import Options.Applicative import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess)@@ -31,10 +34,13 @@ import Angel.Log (logger) import Angel.Config (monitorConfig) import Angel.Data (GroupConfig(GroupConfig),- spec)+ Options(..),+ spec,+ Verbosity(..),+ AngelM,+ runAngelM) import Angel.Job (pollStale, syncSupervisors)-import Angel.Files (startFileManager) -- |Signal handler: when a HUP is trapped, write to the wakeSig Tvar -- |to make the configuration monitor loop cycle/reload@@ -45,57 +51,84 @@ handleExit mv = putMVar mv True main :: IO ()-main = handleArgs =<< getArgs+main = runWithOpts =<< execParser opts -handleArgs :: [String] -> IO ()-handleArgs ["--help"] = printHelp-handleArgs ["-h"] = printHelp-handleArgs [] = printHelp-handleArgs [configPath] = runWithConfigPath configPath-handleArgs _ = errorExit "expected a single config file. Run with --help for usasge."+opts :: ParserInfo Options+opts = info (helper <*> opts')+ (fullDesc <> header "angel - Process management and supervision daemon")+ where+ opts' = Options+ <$> strArgument (metavar "CONFIG_FILE")+ <*> option readVOpt (short 'v' <>+ value V2 <>+ showDefaultWith vOptAsNumber <>+ metavar "VERBOSITY" <>+ help "Verbosity from 0-2") -printHelp :: IO ()-printHelp = putStrLn "Usage: angel [--help] CONFIG_FILE" >> exitSuccess+vOptAsNumber :: Verbosity -> String+vOptAsNumber V2 = "2"+vOptAsNumber V1 = "1"+vOptAsNumber V0 = "0" -runWithConfigPath :: FilePath -> IO ()-runWithConfigPath configPath = do- hSetBuffering stdout LineBuffering- hSetBuffering stderr LineBuffering++readVOpt :: ReadM Verbosity+readVOpt = eitherReader $ \s ->+ case s of+ "0" -> return V0+ "1" -> return V1+ "2" -> return V2+ _ -> Left "Expecting 0-2"++runWithOpts :: Options -> IO ()+runWithOpts os = runAngelM os runWithConfigPath+++runWithConfigPath :: AngelM ()+runWithConfigPath = do+ configPath <- asks configFile+ liftIO $ hSetBuffering stdout LineBuffering+ liftIO $ hSetBuffering stderr LineBuffering let logger' = logger "main"- logger' "Angel started"+ logger' V2 "Angel started" - logger' $ "Using config file: " ++ configPath+ logger' V2 $ "Using config file: " ++ configPath -- Create the TVar that represents the "global state" of running applications -- and applications that _should_ be running- fileReqChan <- atomically newTChan- sharedGroupConfig <- newTVarIO $ GroupConfig M.empty M.empty fileReqChan+ fileReqChan <- liftIO $ atomically newTChan+ sharedGroupConfig <- liftIO $ newTVarIO $ GroupConfig M.empty M.empty fileReqChan -- The wake signal, set by the HUP handler to wake the monitor loop- wakeSig <- newTVarIO Nothing- installHandler sigHUP (Catch $ handleHup wakeSig) Nothing+ wakeSig <- liftIO $ newTVarIO Nothing+ liftIO $ installHandler sigHUP (Catch $ handleHup wakeSig) Nothing -- Handle dying- bye <- newEmptyMVar- installHandler sigTERM (Catch $ handleExit bye) Nothing- installHandler sigINT (Catch $ handleExit bye) Nothing+ bye <- liftIO newEmptyMVar+ liftIO $ installHandler sigTERM (Catch $ handleExit bye) Nothing+ liftIO $ installHandler sigINT (Catch $ handleExit bye) Nothing -- Fork off an ongoing state monitor to watch for inconsistent state- forkIO $ pollStale sharedGroupConfig- forkIO $ startFileManager fileReqChan+ forkIO' $ pollStale sharedGroupConfig -- Finally, run the config load/monitor thread- forkIO $ forever $ monitorConfig configPath sharedGroupConfig wakeSig+ forkIO' $ forever $ monitorConfig configPath sharedGroupConfig wakeSig - _ <- takeMVar bye- logger' "INT | TERM received; initiating shutdown..."- logger' " 1. Clearing config"- atomically $ do+ liftIO $ takeMVar bye++ logger' V2 "INT | TERM received; initiating shutdown..."+ logger' V2 " 1. Clearing config"+ liftIO $ atomically $ do cfg <- readTVar sharedGroupConfig writeTVar sharedGroupConfig cfg {spec = M.empty}- logger' " 2. Forcing sync to kill running processes"+ logger' V2 " 2. Forcing sync to kill running processes" syncSupervisors sharedGroupConfig- logger' "That's all folks!"+ logger' V2 "That's all folks!" errorExit :: String -> IO () errorExit msg = hPutStrLn stderr msg >> exitFailure+++forkIO' :: AngelM () -> AngelM ()+forkIO' f = do+ r <- ask+ void $ liftIO $ forkIO $ runAngelM r f