module System.Posix.Daemon (
startDaemon, stopDaemon,
becomeGroupUser
) where
import Control.Monad ( when )
import System.Directory ( doesFileExist )
import System.Exit ( ExitCode(..) )
import System.IO ( SeekMode(..) )
import System.Posix.Directory ( changeWorkingDirectory )
import System.Posix.Files ( setFileCreationMask
, unionFileModes, otherModes, groupWriteMode )
import System.Posix.IO ( openFd, OpenMode(..), defaultFileFlags, closeFd
, dupTo, stdInput, stdOutput, stdError, getLock
, LockRequest (..), createFile, setLock, fdWrite
)
import System.Posix.Process ( getProcessID
, forkProcess, exitImmediately, createSession )
import System.Posix.Signals ( installHandler, sigHUP, Handler(..)
, signalProcess )
import System.Posix.Types ( ProcessID )
import System.Posix.User ( groupID, setGroupID, getGroupEntryForName
, userID, setUserID, getUserEntryForName )
startDaemon :: FilePath
-> IO ()
-> IO ()
-> IO ()
startDaemon pidFile handler program = do
checkRunning
_ <- forkProcess p
exitImmediately ExitSuccess
where
p = do
_ <- createSession
_ <- forkProcess p'
return ()
p' = do
remapFds
_ <- setFileCreationMask $ unionFileModes otherModes groupWriteMode
changeWorkingDirectory "/"
_ <- installHandler sigHUP (Catch handler) Nothing
setRunning
program
remapFds = do
devnull <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
mapM_ (dupTo devnull) [stdInput, stdOutput, stdError]
closeFd devnull
checkRunning = do
fe <- doesFileExist pidFile
when fe $ do
fd <- openFd pidFile WriteOnly Nothing defaultFileFlags
ml <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
closeFd fd
case ml of
Just (pid, _) -> fail (show pid ++ " already running")
Nothing -> return ()
setRunning = do
fd <- createFile pidFile 777
setLock fd (WriteLock, AbsoluteSeek, 0, 0)
pid <- getProcessID
_ <- fdWrite fd (show pid)
return ()
stopDaemon :: FilePath
-> IO (Maybe ProcessID)
stopDaemon pidFile = do
fe <- doesFileExist pidFile
if fe
then do
pid <- return . read =<< readFile pidFile
signalProcess sigHUP pid
return (Just pid)
else
return Nothing
becomeGroupUser :: String
-> String
-> IO ()
becomeGroupUser group user = do
getGroupEntryForName group >>= setGroupID . groupID
getUserEntryForName user >>= setUserID . userID