PageRenderTime 12ms CodeModel.GetById 2ms app.highlight 7ms RepoModel.GetById 1ms app.codeStats 0ms

/Angel/Job.hs

http://github.com/jamwt/Angel
Haskell | 129 lines | 93 code | 24 blank | 12 comment | 8 complexity | 88283d03ff6bb68b83e76c385ba27a78 MD5 | raw file
  1module Angel.Job where
  2
  3import Data.String.Utils (split, strip)
  4import Data.Maybe (isJust, fromJust, fromMaybe)
  5import System.Process (createProcess, proc, waitForProcess, ProcessHandle)
  6import System.Process (terminateProcess, CreateProcess(..), StdStream(..))
  7import Control.Concurrent
  8import Control.Concurrent.STM
  9import Control.Concurrent.STM.TVar (readTVar, writeTVar)
 10import qualified Data.Map as M
 11import Control.Monad (unless, when, forever)
 12
 13import Angel.Log (logger)
 14import Angel.Data
 15import Angel.Util (sleepSecs)
 16import Angel.Files (getFile)
 17
 18ifEmpty :: String -> IO () -> IO () -> IO ()
 19ifEmpty s ioa iob = if s == "" then ioa else iob
 20-- |launch the program specified by `id`, opening (and closing) the
 21-- |appropriate fds for logging.  When the process dies, either b/c it was
 22-- |killed by a monitor, killed by a system user, or ended execution naturally,
 23-- |re-examine the desired run config to determine whether to re-run it.  if so,
 24-- |tail call.
 25supervise sharedGroupConfig id = do 
 26    let log = logger $ "- program: " ++ id ++ " -"
 27    log "START"
 28    cfg <- atomically $ readTVar sharedGroupConfig
 29    let my_spec = find_me cfg
 30    ifEmpty (name my_spec) 
 31
 32        (log "QUIT (missing from config on restart)" >> deleteRunning) 
 33        
 34        (do
 35            (attachOut, attachErr) <- makeFiles my_spec cfg
 36
 37            let (cmd, args) = cmdSplit $ (fromJust $ exec my_spec)
 38            
 39            (_, _, _, p) <- createProcess (proc cmd args){
 40            std_out = attachOut,
 41            std_err = attachErr,
 42            cwd = workingDir my_spec 
 43            }
 44            
 45            updateRunningPid my_spec (Just p)
 46            log "RUNNING"
 47            waitForProcess p
 48            log "ENDED"
 49            updateRunningPid my_spec (Nothing)
 50            
 51            cfg <- atomically $ readTVar sharedGroupConfig
 52            if M.notMember id (spec cfg) 
 53
 54                then do 
 55                log  "QUIT"
 56                deleteRunning
 57
 58                else do 
 59                log  "WAITING"
 60                sleepSecs $ (fromMaybe defaultDelay $ delay my_spec)
 61                log  "RESTART"
 62                supervise sharedGroupConfig id
 63        )
 64        
 65    where
 66        cmdSplit fullcmd = (head parts, tail parts) 
 67            where parts = (filter (/="") . map strip . split " ") fullcmd
 68
 69        find_me cfg = M.findWithDefault defaultProgram id (spec cfg)
 70        updateRunningPid my_spec mpid = atomically $ do 
 71            wcfg <- readTVar sharedGroupConfig
 72            writeTVar sharedGroupConfig wcfg{
 73              running=M.insertWith' (\n o-> n) id (my_spec, mpid) (running wcfg)
 74            }
 75                
 76        deleteRunning = atomically $ do 
 77            wcfg <- readTVar sharedGroupConfig
 78            writeTVar sharedGroupConfig wcfg{
 79                running=M.delete id (running wcfg)
 80            }
 81            
 82        makeFiles my_spec cfg = do
 83            let useout = fromMaybe defaultStdout $ stdout my_spec
 84            attachOut <- UseHandle `fmap` getFile useout cfg
 85
 86            let useerr = fromMaybe defaultStderr $ stderr my_spec
 87            attachErr <- UseHandle `fmap` getFile useerr cfg
 88
 89            return $ (attachOut, attachErr)
 90
 91
 92-- |send a TERM signal to all provided process handles
 93killProcesses :: [ProcessHandle] -> IO ()
 94killProcesses pids = mapM_ terminateProcess pids
 95
 96-- |fire up new supervisors for new program ids
 97startProcesses :: TVar GroupConfig -> [String] -> IO ()
 98startProcesses sharedGroupConfig starts = mapM_ spawnWatcher starts
 99    where
100        spawnWatcher s = forkIO $ supervise sharedGroupConfig s
101
102-- |diff the requested config against the actual run state, and
103-- |do any start/kill action necessary
104syncSupervisors :: TVar GroupConfig -> IO ()
105syncSupervisors sharedGroupConfig = do 
106   let log = logger "process-monitor"
107   cfg <- atomically $ readTVar sharedGroupConfig
108   let kills = mustKill cfg
109   let starts = mustStart cfg
110   when (length kills > 0 || length starts > 0) $ log (
111         "Must kill=" ++ (show $ length kills)
112                ++ ", must start=" ++ (show $ length starts))
113   killProcesses kills
114   startProcesses sharedGroupConfig starts
115                                         
116    where
117        mustKill cfg = map (fromJust . snd . snd) $ filter (runningAndDifferent $ spec cfg) $ M.assocs (running cfg)
118        runningAndDifferent spec (id, (pg, pid)) = (isJust pid && (M.notMember id spec 
119                                           || M.findWithDefault defaultProgram id spec `cmp` pg))
120            where cmp one two = one /= two
121
122        mustStart cfg = map fst $ filter (isNew $ running cfg) $ M.assocs (spec cfg)
123        isNew running (id, pg) = M.notMember id running
124
125-- |periodically run the supervisor sync independent of config reload,
126-- |just in case state gets funky b/c of theoretically possible timing
127-- |issues on reload
128pollStale :: TVar GroupConfig -> IO ()
129pollStale sharedGroupConfig = forever $ sleepSecs 10 >> syncSupervisors sharedGroupConfig