Commands.hs

{-# LANGUAGE ScopedTypeVariables #-}
module Bein.Daemon.Commands (
  module Bein.Commands,
  exitDaemon,
  reconfigureDaemon,
  updateJobs,
  database,
  runMinion
) where

import Control.Concurrent.QSem ( signalQSem, waitQSem )
import System.Posix.Process
    ( executeFile, exitImmediately, forkProcess )
import System.Random ( Random(randomR), getStdGen, setStdGen )
import Database.HDBC.PostgreSQL ( Connection )
import Database.HDBC
    ( fromSql, toSql )
import Control.Monad.Trans ()
import Control.Monad.Reader ( MonadReader(ask), MonadIO(..) )
import Control.Concurrent.STM ( atomically, writeTVar )
import Control.Exception ()
import System.Exit ( ExitCode(ExitSuccess) )
import System.Posix.Process ()
import System.Posix.Syslog ( syslog, Priority(Notice, Error) )
import System.Posix.Files ( removeLink, fileExist )
import Bein.Commands ( encodeResponse, forkR, catchR, query, update )
import Bein.Configuration ( readConfiguration )
import Bein.Daemon.Types
    ( Configuration(max_executions, minion_command),
      BeinState(..),
      BeinM,
      ExecutionID(..),
      configField,
      DaemonState(stSem) )

exitDaemon :: BeinM a ()
exitDaemon = liftIO $ do
  removeLink "/var/run/beind.pid"
  syslog Notice "Exiting."
  exitImmediately ExitSuccess

reconfigureDaemon :: BeinM DaemonState ()
reconfigureDaemon = do
  liftIO $ syslog Notice "Reconfiguring."
  st <- ask
  config <- liftIO $ readConfiguration (db st)
  liftIO $ atomically $ writeTVar (configT st) config

updateJobs :: BeinM DaemonState ()
updateJobs = do
  jobSemaphore <- ask >>= return.stSem
  liftIO $ waitQSem jobSemaphore
  maxExecutions <- configField max_executions
  toRun <- query queryString [toSql maxExecutions]
  mapM_ runMinion (map (fromSql.head) toRun)
  liftIO $ signalQSem jobSemaphore
    where queryString = "select id from current_jobs where status = 'pending' " ++ 
                        "limit (select ?-count(id) from current_jobs where status='running')"

database :: BeinM DaemonState Connection
database = ask >>= return.db

randomFileName :: Int -> IO String
randomFileName n = do
  g <- getStdGen
  let (s, g') = randomFileName' g n
  setStdGen g'
  return s
    where randomFileName' g 0 = ([],g)
          randomFileName' g m = let (k,g') = randomR (0,61) g
                                    (str,g'') = randomFileName' g' (m-1)
                                in (toChar k : str, g'')
          toChar :: Int -> Char
          toChar q = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" !! q

runMinion :: ExecutionID -> BeinM DaemonState ()
runMinion (ExecutionID ex) = do
  minionCmd <- configField minion_command
  d <- liftIO $ randomFileName 50
  (liftIO $ fileExist minionCmd) >>= \b -> if b  
    then do p <- liftIO $ forkProcess $ executeFile minionCmd False ["-x",show ex,"-d",d] Nothing
            update "update current_jobs set (status,running_as_pid,scratch_dir) = ('running',?,?) where id = ?" 
              [toSql $ toInteger p, toSql d, toSql ex]
    else do update "update executions set status='failed' where id=?" [toSql ex]
            liftIO $ syslog Error "beinminion does not exist.  Can't execute jobs."