module ALife.Creatur.Daemon
(
Daemon(..),
launch
) where
import Control.Concurrent (MVar, newMVar, readMVar, swapMVar,
threadDelay)
import Control.Exception (SomeException, handle, catch)
import Control.Monad (when)
import Control.Monad.State (StateT, runStateT)
import System.IO (hPutStr, stderr)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Daemonize (CreateDaemon(..), serviced, simpleDaemon)
import System.Posix.Signals (Handler(Catch), fullSignalSet,
installHandler, sigTERM)
import System.Posix.User (getLoginName, getRealUserID)
termReceived :: MVar Bool
termReceived = unsafePerformIO (newMVar False)
data Daemon s = Daemon
{
onStartup :: s -> IO s,
onShutdown :: s -> IO (),
onException :: s -> SomeException -> IO (Bool, s),
task :: StateT s IO Bool,
username :: String,
sleepTime :: Int
}
launch :: Daemon s -> s -> IO ()
launch d s = do
uid <- getRealUserID
if uid /= 0
then putStrLn "Must run as root"
else do
u <- daemonUsername d
serviced $ simpleDaemon
{ program = daemonMain d s,
user = Just u }
daemonUsername :: Daemon s -> IO String
daemonUsername d =
if (null . username) d
then getLoginName
else (return . username) d
daemonMain :: Daemon s -> s -> () -> IO ()
daemonMain d s _ = do
s' <- onStartup d s
_ <- installHandler sigTERM (Catch handleTERM) (Just fullSignalSet)
_ <- wrap (daemonMainLoop d s')
return ()
daemonMainLoop :: Daemon s -> s -> IO ()
daemonMainLoop d s = do
stopRequested <- readMVar termReceived
when (not stopRequested) $ do
(continue, s') <- handle (onException d s) $ runStateT (task d) s
when continue $ do
threadDelay $ sleepTime d
daemonMainLoop d s'
onShutdown d s
wrap :: IO () -> IO ()
wrap t = catch t
(\e -> do
let err = show (e :: SomeException)
hPutStr stderr ("Unhandled exception: " ++ err)
return ())
handleTERM :: IO ()
handleTERM = do
_ <- swapMVar termReceived True
return ()