{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Posix.Daemonize (
daemonize,
serviced, serviced', CreateDaemon(..), simpleDaemon, Operation(..),
fatalError, exitCleanly,
syslog
) where
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)
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 :: 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 :: 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
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
data CreateDaemon a = CreateDaemon {
forall a. CreateDaemon a -> IO a
privilegedAction :: IO a,
forall a. CreateDaemon a -> a -> IO ()
program :: a -> IO (),
forall a. CreateDaemon a -> Maybe [Char]
name :: Maybe String,
forall a. CreateDaemon a -> Maybe [Char]
user :: Maybe String,
forall a. CreateDaemon a -> Maybe [Char]
group :: Maybe String,
forall a. CreateDaemon a -> [Option]
syslogOptions :: [Option],
forall a. CreateDaemon a -> Maybe [Char]
pidfileDirectory :: Maybe FilePath,
forall a. CreateDaemon a -> Maybe Int
killWait :: Maybe Int
}
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
}
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
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 ()
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
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