Commands.hs

module Bein.Minion.Commands (
  module Bein.Commands,
  ifVerbose, verboseMsg, verboseMsgLn,
  scratchDir, execution, minionSocket,
  minionPid, writeMinionPid,
  dieWith,
  query, update,
  cleanUp,
  receiveOneRow,
  ignoreSignal
) where

import Database.HDBC
    ( SqlValue, toSql, IConnection(commit, run), quickQuery' )
import Control.Monad.Trans ()
import System.IO ()
import Control.Monad.Reader
    ( MonadReader(ask), MonadIO(..), ReaderT )
import System.Posix.Types ( ProcessID )
import Control.Concurrent.STM ( atomically, readTVar, writeTVar )
import System.Exit ( ExitCode(ExitFailure) )
import System.IO ()
import System.Environment ()
import System.Console.GetOpt ()
import System.FilePath.Posix ( joinPath )
import System.Directory
    ( removeDirectoryRecursive, setCurrentDirectory )
import System.Posix.Signals
    ( Signal, Handler(Ignore), installHandler, sigKILL, signalProcess )
import System.Posix.Process ( exitImmediately )
import System.IO ( stdout, hPutStrLn, hFlush )
import Bein.Commands ( encodeResponse, forkR, catchR, database, maybeRowQuery )
import Bein.Minion.Types
    ( Configuration(minion_port, scratch_directory),
      BeinM,
      ExecutionID,
      configField,
      State(stMinionPid, stSettings),
      Settings(setExecution, setScratchDir, setVerbose) )
import Bein.Minion.Arguments ()

ifVerbose :: ReaderT State IO () -> ReaderT State IO ()
ifVerbose act = ask >>= \st -> if setVerbose (stSettings st) then act else return ()

verboseMsg :: String -> ReaderT State IO ()
verboseMsg m = ifVerbose $ liftIO $ putStr m >> hFlush stdout

verboseMsgLn :: String -> BeinM State ()
verboseMsgLn m = ifVerbose $ liftIO $ putStrLn m >> hFlush stdout

scratchDir :: ReaderT State IO FilePath
scratchDir = do 
  st <- ask 
  baseDir <- configField scratch_directory
  let scrDir = setScratchDir $ stSettings st
  return $ joinPath [baseDir, scrDir]

execution :: ReaderT State IO ExecutionID
execution = ask >>= return.stSettings >>= return.setExecution

minionSocket :: ReaderT State IO FilePath
minionSocket = do
  dir <- scratchDir
  minionSocketName <- configField minion_port
  return $ joinPath [dir,minionSocketName]

minionPid :: ReaderT State IO (Maybe ProcessID)
minionPid = ask >>= return.stMinionPid >>= liftIO.atomically.readTVar

writeMinionPid :: ProcessID -> ReaderT State IO ()
writeMinionPid pid = ask >>= return.stMinionPid >>= \v -> 
  liftIO $ atomically $ writeTVar v (Just pid)
  
dieWith :: String -> BeinM State a
dieWith m = (liftIO $ hPutStrLn stdout m) >> cleanUp (ExitFailure 1)

query :: String -> [SqlValue] -> BeinM State [[SqlValue]]
query q vs = database >>= \conn -> liftIO $ quickQuery' conn q vs

update :: String -> [SqlValue] -> BeinM State ()
update q vs = database >>= (\conn -> liftIO $ run conn q vs >> commit conn)

cleanUp :: ExitCode -> BeinM State a
cleanUp term = do
  minionPid >>= \p -> liftIO $ (case p of 
                                   Nothing -> return ()
                                   Just pid -> signalProcess sigKILL pid) `catch` (const $ return ())
  configField scratch_directory >>= liftIO.setCurrentDirectory 
  scratchDir >>= \d -> liftIO $ (removeDirectoryRecursive d `catch` (const $ return ()))
  execution >>= \ex -> update updateString [toSql ex]
  liftIO $ exitImmediately term
  return undefined
      where updateString = "update executions set status = 'failed' " ++
                           "where id=? and status='running'"

receiveOneRow :: BeinM State [[a]] -> BeinM State [a]
receiveOneRow act = act >>= \r -> case r of
  [] -> dieWith "Received no rows from database."
  [a] -> return a
  _ -> dieWith "Received multiple rows from database."
  
ignoreSignal :: Signal -> BeinM s Handler
ignoreSignal sig = liftIO $ installHandler sig Ignore Nothing