diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ------ diff --git a/angel.cabal b/angel.cabal --- a/angel.cabal +++ b/angel.cabal @@ -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 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 diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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. diff --git a/src/Angel/Config.hs b/src/Angel/Config.hs --- a/src/Angel/Config.hs +++ b/src/Angel/Config.hs @@ -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 diff --git a/src/Angel/Data.hs b/src/Angel/Data.hs --- a/src/Angel/Data.hs +++ b/src/Angel/Data.hs @@ -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 diff --git a/src/Angel/Files.hs b/src/Angel/Files.hs --- a/src/Angel/Files.hs +++ b/src/Angel/Files.hs @@ -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 diff --git a/src/Angel/Job.hs b/src/Angel/Job.hs --- a/src/Angel/Job.hs +++ b/src/Angel/Job.hs @@ -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 diff --git a/src/Angel/Log.hs b/src/Angel/Log.hs --- a/src/Angel/Log.hs +++ b/src/Angel/Log.hs @@ -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 diff --git a/src/Angel/Main.hs b/src/Angel/Main.hs --- a/src/Angel/Main.hs +++ b/src/Angel/Main.hs @@ -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