{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Posix.Daemonize (
  -- * Simple daemonization
  daemonize,
  -- * Building system services
  serviced, serviced', CreateDaemon(..), simpleDaemon, Operation(..),
  -- * Intradaemon utilities
  fatalError, exitCleanly,
  -- * Logging utilities
  syslog
  ) where

{- originally based on code from
   http://sneakymustard.com/2008/12/11/haskell-daemons -}


import Control.Applicative(pure)
import Control.Monad (when)
import Control.Monad.Trans
import Control.Exception.Extensible
import qualified Control.Monad as M (forever)

#if MIN_VERSION_base(4,6,0)
import Prelude
#else
import Prelude hiding (catch)
#endif

#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative ((<$), (<$>))
#endif

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as ByteString
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)

import Data.Foldable (asum)

import Data.Maybe (isNothing, fromMaybe, fromJust)
import System.Environment
import System.Exit
import System.Posix hiding (Start, Stop)
import System.Posix.Syslog (Priority(..), Facility(Daemon), Option, withSyslog)
import qualified System.Posix.Syslog as Log
import System.FilePath.Posix (joinPath)

data Operation = Start | Stop | Restart | Status deriving (Operation -> Operation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Operation -> Operation -> Bool
$c/= :: Operation -> Operation -> Bool
== :: Operation -> Operation -> Bool
$c== :: Operation -> Operation -> Bool
Eq, Int -> Operation -> ShowS
[Operation] -> ShowS
Operation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Operation] -> ShowS
$cshowList :: [Operation] -> ShowS
show :: Operation -> [Char]
$cshow :: Operation -> [Char]
showsPrec :: Int -> Operation -> ShowS
$cshowsPrec :: Int -> Operation -> ShowS
Show)

syslog :: Priority -> ByteString -> IO ()
syslog :: Priority -> ByteString -> IO ()
syslog Priority
pri ByteString
msg = forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
msg (Maybe Facility -> Priority -> CStringLen -> IO ()
Log.syslog (forall a. a -> Maybe a
Just Facility
Daemon) Priority
pri)

-- | Turning a process into a daemon involves a fixed set of
-- operations on unix systems, described in section 13.3 of Stevens
-- and Rago, "Advanced Programming in the Unix Environment."  Since
-- they are fixed, they can be written as a single function,
-- 'daemonize' taking an 'IO' action which represents the daemon's
-- actual activity.
--
-- Briefly, 'daemonize' sets the file creation mask to 0, forks twice,
-- changed the working directory to @/@, closes stdin, stdout, and
-- stderr, blocks 'sigHUP', and runs its argument.  Strictly, it
-- should close all open file descriptors, but this is not possible in
-- a sensible way in Haskell.
--
-- The most trivial daemon would be
--
-- > daemonize (forever $ return ())
--
-- which does nothing until killed.

daemonize :: IO () -> IO ()
daemonize :: IO () -> IO ()
daemonize IO ()
program = do
        FileMode -> IO FileMode
setFileCreationMask FileMode
0
        IO () -> IO ProcessID
forkProcess IO ()
p
        ExitCode -> IO ()
exitImmediately ExitCode
ExitSuccess
    where
      p :: IO ()
p  = do IO ProcessID
createSession
              IO () -> IO ProcessID
forkProcess IO ()
p'
              ExitCode -> IO ()
exitImmediately ExitCode
ExitSuccess
      p' :: IO ()
p' = do [Char] -> IO ()
changeWorkingDirectory [Char]
"/"
              IO ()
closeFileDescriptors
              Signal -> IO ()
blockSignal Signal
sigHUP
              IO ()
program




-- | 'serviced' turns a program into a UNIX daemon (system service)
--   ready to be deployed to /etc/rc.d or similar startup folder.  It
--   is meant to be used in the @main@ function of a program, such as
--
-- > serviced simpleDaemon
--
--   The resulting program takes one of three arguments: @start@,
--   @stop@, and @restart@.  All control the status of a daemon by
--   looking for a file containing a text string holding the PID of
--   any running instance.  Conventionally, this file is in
--   @/var/run/$name.pid@, where $name is the executable's name.  For
--   obvious reasons, this file is known as a PID file.
--
--   @start@ makes the program write a PID file.  If the file already
--   exists, it refuses to start, guaranteeing there is only one
--   instance of the daemon at any time.
--
--   @stop@ read the PID file, and terminates the process whose pid is
--   written therein.  First it does a soft kill, SIGTERM, giving the
--   daemon a chance to shut down cleanly, then three seconds later a
--   hard kill which the daemon cannot catch or escape.
--
--   @restart@ is simple @stop@ followed by @start@.
--
--   'serviced' also tries to drop privileges.  If you don't specify a
--   user the daemon should run as, it will try to switch to a user
--   with the same name as the daemon, and otherwise to user @daemon@.
--   It goes through the same sequence for group.  Just to complicate
--   matters, the name of the daemon is by default the name of the
--   executable file, but can again be set to something else in the
--   'CreateDaemon' record.
--
--   Finally, exceptions in the program are caught, logged to syslog,
--   and the program restarted.

serviced :: CreateDaemon a -> IO ()
serviced :: forall a. CreateDaemon a -> IO ()
serviced CreateDaemon a
daemon = do
        [[Char]]
args <- IO [[Char]]
getArgs

        let mOperation :: Maybe Operation
            mOperation :: Maybe Operation
mOperation = case [[Char]]
args of
              ([Char]
"start" : [[Char]]
_)   -> forall a. a -> Maybe a
Just Operation
Start
              ([Char]
"stop" : [[Char]]
_)    -> forall a. a -> Maybe a
Just Operation
Stop
              ([Char]
"restart" : [[Char]]
_) -> forall a. a -> Maybe a
Just Operation
Restart
              ([Char]
"status" : [[Char]]
_)  -> forall a. a -> Maybe a
Just Operation
Status
              [[Char]]
_               -> forall a. Maybe a
Nothing

        if forall a. Maybe a -> Bool
isNothing Maybe Operation
mOperation
          then IO [Char]
getProgName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
pname -> [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"usage: " forall a. [a] -> [a] -> [a]
++ [Char]
pname forall a. [a] -> [a] -> [a]
++ [Char]
" {start|stop|status|restart}"
          else forall a. CreateDaemon a -> Operation -> IO ()
serviced' CreateDaemon a
daemon forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust Maybe Operation
mOperation

serviced' :: CreateDaemon a -> Operation -> IO ()
serviced' :: forall a. CreateDaemon a -> Operation -> IO ()
serviced' CreateDaemon a
daemon Operation
operation = do
        [Char]
systemName <- IO [Char]
getProgName
        let daemon' :: CreateDaemon a
daemon' = CreateDaemon a
daemon { name :: Maybe [Char]
name = if forall a. Maybe a -> Bool
isNothing (forall a. CreateDaemon a -> Maybe [Char]
name CreateDaemon a
daemon)
                                        then forall a. a -> Maybe a
Just [Char]
systemName else forall a. CreateDaemon a -> Maybe [Char]
name CreateDaemon a
daemon }
        forall a. CreateDaemon a -> Operation -> IO ()
process CreateDaemon a
daemon' Operation
operation
    where
      program' :: CreateDaemon a -> IO ()
program' CreateDaemon a
daemon = forall a. [Char] -> [Option] -> Facility -> IO a -> IO a
withSyslog (forall a. HasCallStack => Maybe a -> a
fromJust (forall a. CreateDaemon a -> Maybe [Char]
name CreateDaemon a
daemon)) (forall a. CreateDaemon a -> [Option]
syslogOptions CreateDaemon a
daemon) Facility
Daemon forall a b. (a -> b) -> a -> b
$
                      do let log :: ByteString -> IO ()
log = Priority -> ByteString -> IO ()
syslog Priority
Notice
                         ByteString -> IO ()
log ByteString
"starting"
                         forall a. CreateDaemon a -> IO ()
pidWrite CreateDaemon a
daemon
                         a
privVal <- forall a. CreateDaemon a -> IO a
privilegedAction CreateDaemon a
daemon
                         forall a. CreateDaemon a -> IO ()
dropPrivileges CreateDaemon a
daemon
                         IO () -> IO ()
forever forall a b. (a -> b) -> a -> b
$ forall a. CreateDaemon a -> a -> IO ()
program CreateDaemon a
daemon a
privVal

      process :: CreateDaemon a -> Operation -> IO ()
process CreateDaemon a
daemon Operation
Start = forall a. CreateDaemon a -> IO Bool
pidExists CreateDaemon a
daemon forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO ()
f where
          f :: Bool -> IO ()
f Bool
True  = do forall a. HasCallStack => [Char] -> a
error [Char]
"PID file exists. Process already running?"
                       ExitCode -> IO ()
exitImmediately (Int -> ExitCode
ExitFailure Int
1)
          f Bool
False = IO () -> IO ()
daemonize (forall a. CreateDaemon a -> IO ()
program' CreateDaemon a
daemon)

      process CreateDaemon a
daemon Operation
Stop  =
          do Maybe ProcessID
pid <- forall a. CreateDaemon a -> IO (Maybe ProcessID)
pidRead CreateDaemon a
daemon
             case Maybe ProcessID
pid of
               Maybe ProcessID
Nothing  -> IO ()
pass
               Just ProcessID
pid ->
                   forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (ProcessID -> IO Bool
pidLive ProcessID
pid)
                            (do Signal -> ProcessID -> IO ()
signalProcess Signal
sigTERM ProcessID
pid
                                Int -> IO ()
usleep (Int
10forall a b. (Num a, Integral b) => a -> b -> a
^Integer
3)
                                Maybe Int -> ProcessID -> IO ()
wait (forall a. CreateDaemon a -> Maybe Int
killWait CreateDaemon a
daemon) ProcessID
pid)
                   forall a b. IO a -> IO b -> IO a
`finally`
                   [Char] -> IO ()
removeLink (forall a. CreateDaemon a -> [Char]
pidFile CreateDaemon a
daemon)

      process CreateDaemon a
daemon Operation
Restart = do CreateDaemon a -> Operation -> IO ()
process CreateDaemon a
daemon Operation
Stop
                                  CreateDaemon a -> Operation -> IO ()
process CreateDaemon a
daemon Operation
Start

      process CreateDaemon a
daemon Operation
Status = forall a. CreateDaemon a -> IO Bool
pidExists CreateDaemon a
daemon forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO ()
f where
        f :: Bool -> IO ()
f Bool
True =
          do Maybe ProcessID
pid <- forall a. CreateDaemon a -> IO (Maybe ProcessID)
pidRead CreateDaemon a
daemon
             case Maybe ProcessID
pid of
               Maybe ProcessID
Nothing -> [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust (forall a. CreateDaemon a -> Maybe [Char]
name CreateDaemon a
daemon) forall a. [a] -> [a] -> [a]
++ [Char]
" is not running."
               Just ProcessID
pid ->
                 do Bool
res <- ProcessID -> IO Bool
pidLive ProcessID
pid
                    if Bool
res then
                              [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust (forall a. CreateDaemon a -> Maybe [Char]
name CreateDaemon a
daemon) forall a. [a] -> [a] -> [a]
++ [Char]
" is running."
                         else [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust (forall a. CreateDaemon a -> Maybe [Char]
name CreateDaemon a
daemon) forall a. [a] -> [a] -> [a]
++ [Char]
" is not running, but pidfile is remaining."
        f Bool
False = [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust (forall a. CreateDaemon a -> Maybe [Char]
name CreateDaemon a
daemon) forall a. [a] -> [a] -> [a]
++ [Char]
" is not running."

      -- Wait 'secs' seconds for the process to exit, checking
      -- for liveness once a second.  If still alive send sigKILL.
      wait :: Maybe Int -> CPid -> IO ()
      wait :: Maybe Int -> ProcessID -> IO ()
wait Maybe Int
secs ProcessID
pid =
          forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (ProcessID -> IO Bool
pidLive ProcessID
pid) forall a b. (a -> b) -> a -> b
$
               if forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Ord a => a -> a -> Bool
> Int
0) Maybe Int
secs
               then do Int -> IO ()
usleep (Int
10forall a b. (Num a, Integral b) => a -> b -> a
^Integer
6)
                       Maybe Int -> ProcessID -> IO ()
wait (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
x->Int
xforall a. Num a => a -> a -> a
-Int
1) Maybe Int
secs) ProcessID
pid
               else Signal -> ProcessID -> IO ()
signalProcess Signal
sigKILL ProcessID
pid

-- | A monadic-conditional version of the "when" guard (copied from shelly.)
whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
c m ()
a = m Bool
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
res -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
res m ()
a

-- | The details of any given daemon are fixed by the 'CreateDaemon'
-- record passed to 'serviced'.  You can also take a predefined form
-- of 'CreateDaemon', such as 'simpleDaemon' below, and set what
-- options you want, rather than defining the whole record yourself.
data CreateDaemon a = CreateDaemon {
  forall a. CreateDaemon a -> IO a
privilegedAction :: IO a, -- ^ An action to be run as root, before
                            -- permissions are dropped, e.g., binding
                            -- a trusted port.
  forall a. CreateDaemon a -> a -> IO ()
program :: a -> IO (), -- ^ The actual guts of the daemon, more or less
                         -- the @main@ function.  Its argument is the result
                         -- of running 'privilegedAction' before dropping
                         -- privileges.
  forall a. CreateDaemon a -> Maybe [Char]
name :: Maybe String, -- ^ The name of the daemon, which is used as
                        -- the name for the PID file, as the name that
                        -- appears in the system logs, and as the user
                        -- and group the daemon tries to run as if
                        -- none are explicitly specified.  In general,
                        -- this should be 'Nothing', in which case the
                        -- system defaults to the name of the
                        -- executable file containing the daemon.
  forall a. CreateDaemon a -> Maybe [Char]
user :: Maybe String, -- ^ Most daemons are initially run as root,
                        -- and try to change to another user so they
                        -- have fewer privileges and represent less of
                        -- a security threat.  This field specifies
                        -- which user it should try to run as.  If it
                        -- is 'Nothing', or if the user does not exist
                        -- on the system, it next tries to become a
                        -- user with the same name as the daemon, and
                        -- if that fails, the user @daemon@.
  forall a. CreateDaemon a -> Maybe [Char]
group :: Maybe String, -- ^ 'group' is the group the daemon should
                         -- try to run as, and works the same way as
                         -- the user field.
  forall a. CreateDaemon a -> [Option]
syslogOptions :: [Option], -- ^ The options the daemon should set on
                             -- syslog.  You can safely leave this as @[]@.
  forall a. CreateDaemon a -> Maybe [Char]
pidfileDirectory :: Maybe FilePath, -- ^ The directory where the
                                      -- daemon should write and look
                                      -- for the PID file.  'Nothing'
                                      -- means @/var/run@.  Unless you
                                      -- have a good reason to do
                                      -- otherwise, leave this as
                                      -- 'Nothing'.
  forall a. CreateDaemon a -> Maybe Int
killWait :: Maybe Int -- ^ How many seconds to wait between sending
                        -- sigTERM and sending sigKILL.  If Nothing
                        -- wait forever.  Default 4.
}

-- | The simplest possible instance of 'CreateDaemon' is
--
-- > CreateDaemon {
-- >  privilegedAction = return ()
-- >  program = const $ forever $ return ()
-- >  name = Nothing,
-- >  user = Nothing,
-- >  group = Nothing,
-- >  syslogOptions = [],
-- >  pidfileDirectory = Nothing,
-- > }
--
-- which does nothing forever with all default settings.  We give it a
-- name, 'simpleDaemon', since you may want to use it as a template
-- and modify only the fields that you need.

simpleDaemon :: CreateDaemon ()
simpleDaemon :: CreateDaemon ()
simpleDaemon = CreateDaemon {
  name :: Maybe [Char]
name = forall a. Maybe a
Nothing,
  user :: Maybe [Char]
user = forall a. Maybe a
Nothing,
  group :: Maybe [Char]
group = forall a. Maybe a
Nothing,
  syslogOptions :: [Option]
syslogOptions = [],
  pidfileDirectory :: Maybe [Char]
pidfileDirectory = forall a. Maybe a
Nothing,
  program :: () -> IO ()
program = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
M.forever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (),
  privilegedAction :: IO ()
privilegedAction = forall (m :: * -> *) a. Monad m => a -> m a
return (),
  killWait :: Maybe Int
killWait = forall a. a -> Maybe a
Just Int
4
}




{- implementation -}

forever :: IO () -> IO ()
forever :: IO () -> IO ()
forever IO ()
program =
    IO ()
program forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO ()
restart where
        restart :: SomeException -> IO ()
        restart :: SomeException -> IO ()
restart SomeException
e =
            do Priority -> ByteString -> IO ()
syslog Priority
Error forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
ByteString.pack ([Char]
"unexpected exception: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show SomeException
e)
               Priority -> ByteString -> IO ()
syslog Priority
Error ByteString
"restarting in 5 seconds"
               Int -> IO ()
usleep (Int
5 forall a. Num a => a -> a -> a
* Int
10forall a b. (Num a, Integral b) => a -> b -> a
^Integer
6)
               IO () -> IO ()
forever IO ()
program

closeFileDescriptors :: IO ()
closeFileDescriptors :: IO ()
closeFileDescriptors =
#if MIN_VERSION_unix(2,8,0)
    do null <- openFd "/dev/null" ReadWrite defaultFileFlags
#else
    do Fd
null <- [Char] -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd [Char]
"/dev/null" OpenMode
ReadWrite forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags
#endif
       let sendTo :: Fd -> Fd -> IO Fd
sendTo Fd
fd' Fd
fd = Fd -> IO ()
closeFd Fd
fd forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> Fd -> IO Fd
dupTo Fd
fd' Fd
fd
       forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Fd -> Fd -> IO Fd
sendTo Fd
null) [Fd
stdInput, Fd
stdOutput, Fd
stdError]

blockSignal :: Signal -> IO ()
blockSignal :: Signal -> IO ()
blockSignal Signal
sig = Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sig Handler
Ignore forall a. Maybe a
Nothing forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
pass

getGroupID :: String -> IO (Maybe GroupID)
getGroupID :: [Char] -> IO (Maybe GroupID)
getGroupID [Char]
group =
        Either IOException GroupID -> Maybe GroupID
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Exception e => IO a -> IO (Either e a)
try (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupEntry -> GroupID
groupID ([Char] -> IO GroupEntry
getGroupEntryForName [Char]
group))
    where
        f :: Either IOException GroupID -> Maybe GroupID
        f :: Either IOException GroupID -> Maybe GroupID
f (Left IOException
_)    = forall a. Maybe a
Nothing
        f (Right GroupID
gid) = forall a. a -> Maybe a
Just GroupID
gid

getUserID :: String -> IO (Maybe UserID)
getUserID :: [Char] -> IO (Maybe UserID)
getUserID [Char]
user =
        Either IOException UserID -> Maybe UserID
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Exception e => IO a -> IO (Either e a)
try (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UserEntry -> UserID
userID ([Char] -> IO UserEntry
getUserEntryForName [Char]
user))
    where
        f :: Either IOException UserID -> Maybe UserID
        f :: Either IOException UserID -> Maybe UserID
f (Left IOException
_)    = forall a. Maybe a
Nothing
        f (Right UserID
uid) = forall a. a -> Maybe a
Just UserID
uid

-- only drop privileges if a user is specified
dropPrivileges :: CreateDaemon a -> IO ()
dropPrivileges :: forall a. CreateDaemon a -> IO ()
dropPrivileges CreateDaemon a
daemon = do
    case forall a. CreateDaemon a -> Maybe [Char]
group CreateDaemon a
daemon of
      Maybe [Char]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just [Char]
targetGroup -> do
        Maybe GroupID
mud <- [Char] -> IO (Maybe GroupID)
getGroupID [Char]
targetGroup
        case Maybe GroupID
mud of
          Maybe GroupID
Nothing -> do Priority -> ByteString -> IO ()
syslog Priority
Error ByteString
"Privilege drop failure, could not identify specified group."
                        ExitCode -> IO ()
exitImmediately (Int -> ExitCode
ExitFailure Int
1)
                        forall a. HasCallStack => a
undefined
          Just GroupID
gd -> GroupID -> IO ()
setGroupID GroupID
gd
    case forall a. CreateDaemon a -> Maybe [Char]
user CreateDaemon a
daemon of
      Maybe [Char]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just [Char]
targetUser -> do
        Maybe UserID
mud <- [Char] -> IO (Maybe UserID)
getUserID [Char]
targetUser
        case Maybe UserID
mud of
          Maybe UserID
Nothing -> do Priority -> ByteString -> IO ()
syslog Priority
Error ByteString
"Privilege drop failure, could not identify specified user."
                        ExitCode -> IO ()
exitImmediately (Int -> ExitCode
ExitFailure Int
1)
                        forall a. HasCallStack => a
undefined
          Just UserID
ud -> UserID -> IO ()
setUserID UserID
ud

pidFile:: CreateDaemon a -> String
pidFile :: forall a. CreateDaemon a -> [Char]
pidFile CreateDaemon a
daemon = [[Char]] -> [Char]
joinPath [[Char]
dir, forall a. HasCallStack => Maybe a -> a
fromJust (forall a. CreateDaemon a -> Maybe [Char]
name CreateDaemon a
daemon) forall a. [a] -> [a] -> [a]
++ [Char]
".pid"]
  where dir :: [Char]
dir = forall a. a -> Maybe a -> a
fromMaybe [Char]
"/var/run" (forall a. CreateDaemon a -> Maybe [Char]
pidfileDirectory CreateDaemon a
daemon)

pidExists :: CreateDaemon a -> IO Bool
pidExists :: forall a. CreateDaemon a -> IO Bool
pidExists CreateDaemon a
daemon = [Char] -> IO Bool
fileExist (forall a. CreateDaemon a -> [Char]
pidFile CreateDaemon a
daemon)

pidRead :: CreateDaemon a -> IO (Maybe CPid)
pidRead :: forall a. CreateDaemon a -> IO (Maybe ProcessID)
pidRead CreateDaemon a
daemon = forall a. CreateDaemon a -> IO Bool
pidExists CreateDaemon a
daemon forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {b}. Read b => Bool -> IO (Maybe b)
choose where
    choose :: Bool -> IO (Maybe b)
choose Bool
True  = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile (forall a. CreateDaemon a -> [Char]
pidFile CreateDaemon a
daemon)
    choose Bool
False = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

pidWrite :: CreateDaemon a -> IO ()
pidWrite :: forall a. CreateDaemon a -> IO ()
pidWrite CreateDaemon a
daemon =
    IO ProcessID
getProcessID forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ProcessID
pid ->
    [Char] -> [Char] -> IO ()
writeFile (forall a. CreateDaemon a -> [Char]
pidFile CreateDaemon a
daemon) (forall a. Show a => a -> [Char]
show ProcessID
pid)

pidLive :: CPid -> IO Bool
pidLive :: ProcessID -> IO Bool
pidLive ProcessID
pid =
    (ProcessID -> IO Int
getProcessPriority ProcessID
pid forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOException -> IO Bool
f where
        f :: IOException -> IO Bool
        f :: IOException -> IO Bool
f IOException
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

pass :: IO ()
pass :: IO ()
pass = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | When you encounter an error where the only sane way to handle it
-- is to write an error to the log and die messily, use fatalError.
-- This is a good candidate for things like not being able to find
-- configuration files on startup.
fatalError :: MonadIO m => String -> m a
fatalError :: forall (m :: * -> *) a. MonadIO m => [Char] -> m a
fatalError [Char]
msg = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Priority -> ByteString -> IO ()
syslog Priority
Error forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
ByteString.pack forall a b. (a -> b) -> a -> b
$ [Char]
"Terminating from error: " forall a. [a] -> [a] -> [a]
++ [Char]
msg
  ExitCode -> IO ()
exitImmediately (Int -> ExitCode
ExitFailure Int
1)
  forall a. HasCallStack => a
undefined -- You will never reach this; it's there to make the type checker happy

-- | Use this function when the daemon should terminate normally.  It
-- logs a message, and exits with status 0.
exitCleanly :: MonadIO m => m a
exitCleanly :: forall (m :: * -> *) a. MonadIO m => m a
exitCleanly = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Priority -> ByteString -> IO ()
syslog Priority
Notice ByteString
"Exiting."
  ExitCode -> IO ()
exitImmediately ExitCode
ExitSuccess
  forall a. HasCallStack => a
undefined -- You will never reach this; it's there to make the type checker happy