module System.Posix.Daemonize (
daemonize,
serviced, CreateDaemon(..), simpleDaemon,
fatalError, exitCleanly,
syslog
) where
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.Maybe (isNothing, fromMaybe, fromJust)
import System.Environment
import System.Exit
import System.Posix
import System.Posix.Syslog (Priority(..), Facility(Daemon), Option, withSyslog)
import qualified System.Posix.Syslog as Log
import System.FilePath.Posix (joinPath)
syslog :: Priority -> ByteString -> IO ()
syslog pri msg = unsafeUseAsCStringLen msg (Log.syslog (Just Daemon) pri)
daemonize :: IO () -> IO ()
daemonize program = do
setFileCreationMask 0
forkProcess p
exitImmediately ExitSuccess
where
p = do createSession
forkProcess p'
exitImmediately ExitSuccess
p' = do changeWorkingDirectory "/"
closeFileDescriptors
blockSignal sigHUP
program
serviced :: CreateDaemon a -> IO ()
serviced daemon = do
systemName <- getProgName
let daemon' = daemon { name = if isNothing (name daemon)
then Just systemName else name daemon }
args <- getArgs
process daemon' args
where
program' daemon = withSyslog (fromJust (name daemon)) (syslogOptions daemon) Daemon $
do let log = syslog Notice
log "starting"
pidWrite daemon
privVal <- privilegedAction daemon
dropPrivileges daemon
forever $ program daemon privVal
process daemon ["start"] = pidExists daemon >>= f where
f True = do error "PID file exists. Process already running?"
exitImmediately (ExitFailure 1)
f False = daemonize (program' daemon)
process daemon ["stop"] =
do pid <- pidRead daemon
case pid of
Nothing -> pass
Just pid ->
whenM (pidLive pid)
(do signalProcess sigTERM pid
usleep (10^3)
wait (killWait daemon) pid)
`finally`
removeLink (pidFile daemon)
process daemon ["restart"] = do process daemon ["stop"]
process daemon ["start"]
process daemon ["status"] = pidExists daemon >>= f where
f True =
do pid <- pidRead daemon
case pid of
Nothing -> putStrLn $ fromJust (name daemon) ++ " is not running."
Just pid ->
do res <- pidLive pid
if res then
putStrLn $ fromJust (name daemon) ++ " is running."
else putStrLn $ fromJust (name daemon) ++ " is not running, but pidfile is remaining."
f False = putStrLn $ fromJust (name daemon) ++ " is not running."
process _ _ =
getProgName >>= \pname -> putStrLn $ "usage: " ++ pname ++ " {start|stop|status|restart}"
wait :: Maybe Int -> CPid -> IO ()
wait secs pid =
whenM (pidLive pid) $
if maybe True (> 0) secs
then do usleep (10^6)
wait (fmap (\x->x1) secs) pid
else signalProcess sigKILL pid
whenM :: Monad m => m Bool -> m () -> m ()
whenM c a = c >>= \res -> when res a
data CreateDaemon a = CreateDaemon {
privilegedAction :: IO a,
program :: a -> IO (),
name :: Maybe String,
user :: Maybe String,
group :: Maybe String,
syslogOptions :: [Option],
pidfileDirectory :: Maybe FilePath,
killWait :: Maybe Int
}
simpleDaemon :: CreateDaemon ()
simpleDaemon = CreateDaemon {
name = Nothing,
user = Nothing,
group = Nothing,
syslogOptions = [],
pidfileDirectory = Nothing,
program = const $ M.forever $ return (),
privilegedAction = return (),
killWait = Just 4
}
forever :: IO () -> IO ()
forever program =
program `catch` restart where
restart :: SomeException -> IO ()
restart e =
do syslog Error $ ByteString.pack ("unexpected exception: " ++ show e)
syslog Error "restarting in 5 seconds"
usleep (5 * 10^6)
forever program
closeFileDescriptors :: IO ()
closeFileDescriptors =
do null <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags
let sendTo fd' fd = closeFd fd >> dupTo fd' fd
mapM_ (sendTo null) [stdInput, stdOutput, stdError]
blockSignal :: Signal -> IO ()
blockSignal sig = installHandler sig Ignore Nothing >> pass
getGroupID :: String -> IO (Maybe GroupID)
getGroupID group =
f <$> try (fmap groupID (getGroupEntryForName group))
where
f :: Either IOException GroupID -> Maybe GroupID
f (Left _) = Nothing
f (Right gid) = Just gid
getUserID :: String -> IO (Maybe UserID)
getUserID user =
f <$> try (fmap userID (getUserEntryForName user))
where
f :: Either IOException UserID -> Maybe UserID
f (Left _) = Nothing
f (Right uid) = Just uid
dropPrivileges :: CreateDaemon a -> IO ()
dropPrivileges daemon =
do Just ud <- getUserID "daemon"
Just gd <- getGroupID "daemon"
let targetUser = fromMaybe (fromJust $ name daemon) (user daemon)
targetGroup = fromMaybe (fromJust $ name daemon) (group daemon)
u <- fromMaybe ud <$> getUserID targetUser
g <- fromMaybe gd <$> getGroupID targetGroup
setGroupID g
setUserID u
pidFile:: CreateDaemon a -> String
pidFile daemon = joinPath [dir, fromJust (name daemon) ++ ".pid"]
where dir = fromMaybe "/var/run" (pidfileDirectory daemon)
pidExists :: CreateDaemon a -> IO Bool
pidExists daemon = fileExist (pidFile daemon)
pidRead :: CreateDaemon a -> IO (Maybe CPid)
pidRead daemon = pidExists daemon >>= choose where
choose True = return . read <$> readFile (pidFile daemon)
choose False = return Nothing
pidWrite :: CreateDaemon a -> IO ()
pidWrite daemon =
getProcessID >>= \pid ->
writeFile (pidFile daemon) (show pid)
pidLive :: CPid -> IO Bool
pidLive pid =
(getProcessPriority pid >> return True) `catch` f where
f :: IOException -> IO Bool
f _ = return False
pass :: IO ()
pass = return ()
fatalError :: MonadIO m => String -> m a
fatalError msg = liftIO $ do
syslog Error $ ByteString.pack $ "Terminating from error: " ++ msg
exitImmediately (ExitFailure 1)
undefined
exitCleanly :: MonadIO m => m a
exitCleanly = liftIO $ do
syslog Notice "Exiting."
exitImmediately ExitSuccess
undefined