------------------------------------------------------------------------
-- |
-- Module      :  ALife.Creatur.Daemon
-- Copyright   :  (c) 2012-2021 Amy de Buitléir
-- License     :  BSD-style
-- Maintainer  :  amy@nualeargais.ie
-- Stability   :  experimental
-- Portability :  portable
--
-- Provides a UNIX daemon to run an experiment using the Créatúr
-- framework.
--
------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies     #-}

module ALife.Creatur.Daemon
  (
    Job(..),
    CreaturDaemon(..),
    simpleDaemon,
    launch,
    launchInteractive,
    requestShutdown
  ) where

import           Control.Concurrent
    (MVar, newMVar, readMVar, swapMVar, threadDelay)
import           Control.Exception      (SomeException, catch, handle)
import           Control.Monad          (when)
import           Control.Monad.State    (StateT, execStateT)
import           Foreign.C.String       (withCStringLen)
import           System.IO              (hPutStrLn, stderr)
import           System.IO.Unsafe       (unsafePerformIO)
import qualified System.Posix.Daemonize as D
import           System.Posix.Signals
    (Handler (Catch), fullSignalSet, installHandler, sigTERM)
import           System.Posix.Syslog
    (Facility (Daemon), Priority (Warning), syslog)
import           System.Posix.User
    (getGroupEntryForID, getLoginName, getRealGroupID, getRealUserID,
    groupName)

termReceived :: MVar Bool
termReceived :: MVar Bool
termReceived = IO (MVar Bool) -> MVar Bool
forall a. IO a -> a
unsafePerformIO (Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
newMVar Bool
False)

-- | The work to be performed by a daemon.
data Job s = Job
  {
    -- | Operations to perform on startup.
    Job s -> s -> IO s
onStartup   :: s -> IO s,
    -- | Operations to perform on shutdown.
    Job s -> s -> IO ()
onShutdown  :: s -> IO (),
    -- | Operations to perform if an exception occurs.
    Job s -> s -> SomeException -> IO s
onException :: s -> SomeException -> IO s,
    -- | Operations to perform repeatedly while running.
    Job s -> StateT s IO ()
task        :: StateT s IO (),
    -- | Number of microseconds to sleep between invocations of @'task'@.
    Job s -> Int
sleepTime   :: Int
  }

data CreaturDaemon p s = CreaturDaemon
  {
    CreaturDaemon p s -> CreateDaemon p
daemon :: D.CreateDaemon p,
    CreaturDaemon p s -> Job s
job    :: Job s
  }

-- | Creates a simple daemon to run a job. The daemon will run under
--   the login name.
simpleDaemon :: Job s -> s -> D.CreateDaemon ()
simpleDaemon :: Job s -> s -> CreateDaemon ()
simpleDaemon Job s
j s
s = CreateDaemon ()
D.simpleDaemon { program :: () -> IO ()
D.program = Job s -> s -> () -> IO ()
forall s. Job s -> s -> () -> IO ()
daemonMain Job s
j s
s,
                                    user :: Maybe String
D.user    = String -> Maybe String
forall a. a -> Maybe a
Just String
"",
                                    group :: Maybe String
D.group   = String -> Maybe String
forall a. a -> Maybe a
Just String
""}

-- | @'launch' daemon state@ creates a daemon, which invokes @daemon@.
--   *Note:* If @'user'@ (in @'daemon'@) is @Just ""@, the daemon will
--   run under the login name. If @'user'@ is Nothing, the daemon will
--   run under the name of the executable file containing the daemon.
launch :: CreaturDaemon p s -> IO ()
launch :: CreaturDaemon p s -> IO ()
launch CreaturDaemon p s
d = do
  UserID
uid <- IO UserID
getRealUserID
  if UserID
uid UserID -> UserID -> Bool
forall a. Eq a => a -> a -> Bool
/= UserID
0
    then String -> IO ()
putStrLn String
"Must run as root"
    else do
      Maybe String
u <- Maybe String -> IO (Maybe String)
defaultToLoginName (CreateDaemon p -> Maybe String
forall a. CreateDaemon a -> Maybe String
D.user (CreateDaemon p -> Maybe String)
-> (CreaturDaemon p s -> CreateDaemon p)
-> CreaturDaemon p s
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CreaturDaemon p s -> CreateDaemon p
forall p s. CreaturDaemon p s -> CreateDaemon p
daemon (CreaturDaemon p s -> Maybe String)
-> CreaturDaemon p s -> Maybe String
forall a b. (a -> b) -> a -> b
$ CreaturDaemon p s
d)
      Maybe String
g <- Maybe String -> IO (Maybe String)
defaultToGroupName (CreateDaemon p -> Maybe String
forall a. CreateDaemon a -> Maybe String
D.user (CreateDaemon p -> Maybe String)
-> (CreaturDaemon p s -> CreateDaemon p)
-> CreaturDaemon p s
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CreaturDaemon p s -> CreateDaemon p
forall p s. CreaturDaemon p s -> CreateDaemon p
daemon (CreaturDaemon p s -> Maybe String)
-> CreaturDaemon p s -> Maybe String
forall a b. (a -> b) -> a -> b
$ CreaturDaemon p s
d)
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Launching daemon as user " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show Maybe String
u
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", group " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show Maybe String
g
      let d' :: CreateDaemon p
d' = (CreaturDaemon p s -> CreateDaemon p
forall p s. CreaturDaemon p s -> CreateDaemon p
daemon CreaturDaemon p s
d) { user :: Maybe String
D.user = Maybe String
u, group :: Maybe String
D.group = Maybe String
g }
      IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (CreateDaemon p -> IO ()
forall a. CreateDaemon a -> IO ()
D.serviced CreateDaemon p
d') SomeException -> IO ()
handleLaunchError

handleLaunchError :: SomeException -> IO ()
handleLaunchError :: SomeException -> IO ()
handleLaunchError SomeException
e = do
  let err :: String
err = SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException)
  Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Warning: Couldn't launch daemon: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

launchInteractive :: Job s -> s -> IO ()
launchInteractive :: Job s -> s -> IO ()
launchInteractive Job s
j s
s = do
  s
s' <- Job s -> s -> IO s
forall s. Job s -> s -> IO s
onStartup Job s
j s
s
  Job s -> s -> () -> IO ()
forall s. Job s -> s -> () -> IO ()
daemonMain Job s
j s
s' ()
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

defaultToLoginName :: Maybe String -> IO (Maybe String)
defaultToLoginName :: Maybe String -> IO (Maybe String)
defaultToLoginName (Just String
"") = (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just IO String
getLoginName
defaultToLoginName Maybe String
x         = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
x

defaultToGroupName :: Maybe String -> IO (Maybe String)
defaultToGroupName :: Maybe String -> IO (Maybe String)
defaultToGroupName (Just String
"") = (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just IO String
getGroupName
defaultToGroupName Maybe String
x         = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
x

getGroupName :: IO String
getGroupName :: IO String
getGroupName = (GroupEntry -> String) -> IO GroupEntry -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupEntry -> String
groupName (IO GroupEntry -> IO String) -> IO GroupEntry -> IO String
forall a b. (a -> b) -> a -> b
$ IO GroupID
getRealGroupID IO GroupID -> (GroupID -> IO GroupEntry) -> IO GroupEntry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GroupID -> IO GroupEntry
getGroupEntryForID

daemonMain :: Job s -> s -> () -> IO ()
daemonMain :: Job s -> s -> () -> IO ()
daemonMain Job s
t s
s ()
_ = do
  s
s' <- (SomeException -> IO s) -> IO s -> IO s
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (Job s -> s -> SomeException -> IO s
forall s. Job s -> s -> SomeException -> IO s
onException Job s
t s
s) (Job s -> s -> IO s
forall s. Job s -> s -> IO s
onStartup Job s
t s
s)
  Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigTERM (IO () -> Handler
Catch IO ()
requestShutdown)
        (SignalSet -> Maybe SignalSet
forall a. a -> Maybe a
Just SignalSet
fullSignalSet)
  ()
_ <- IO () -> IO ()
wrap (Job s -> s -> IO ()
forall s. Job s -> s -> IO ()
daemonMainLoop Job s
t s
s')
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

daemonMainLoop :: Job s -> s -> IO ()
daemonMainLoop :: Job s -> s -> IO ()
daemonMainLoop Job s
t s
s = do
  let st :: Int
st = Job s -> Int
forall s. Job s -> Int
sleepTime Job s
t
  Bool
stopRequested <- MVar Bool -> IO Bool
forall a. MVar a -> IO a
readMVar MVar Bool
termReceived
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
stopRequested) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    s
s' <- (SomeException -> IO s) -> IO s -> IO s
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (Job s -> s -> SomeException -> IO s
forall s. Job s -> s -> SomeException -> IO s
onException Job s
t s
s) (IO s -> IO s) -> IO s -> IO s
forall a b. (a -> b) -> a -> b
$ StateT s IO () -> s -> IO s
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Job s -> StateT s IO ()
forall s. Job s -> StateT s IO ()
task Job s
t) s
s
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
st
    Job s -> s -> IO ()
forall s. Job s -> s -> IO ()
daemonMainLoop Job s
t s
s'
  Job s -> s -> IO ()
forall s. Job s -> s -> IO ()
onShutdown Job s
t s
s

wrap :: IO () -> IO ()
wrap :: IO () -> IO ()
wrap IO ()
t = IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO ()
t
  (\SomeException
e -> do
     let err :: String
err = SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException)
     String -> (CStringLen -> IO ()) -> IO ()
forall a. String -> (CStringLen -> IO a) -> IO a
withCStringLen (String
"Unhandled exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err) ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Facility -> Priority -> CStringLen -> IO ()
syslog (Facility -> Maybe Facility
forall a. a -> Maybe a
Just Facility
Daemon) Priority
Warning
     Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Unhandled exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
     () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

requestShutdown :: IO ()
requestShutdown :: IO ()
requestShutdown = do
  Bool
_ <- MVar Bool -> Bool -> IO Bool
forall a. MVar a -> a -> IO a
swapMVar MVar Bool
termReceived Bool
True
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()