diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,91 +0,0 @@ -`hdaemonize-0.4.3` -================= - -`hdaemonize` is a simple library that hides some of the complexities -of writing UNIX daemons in Haskell. - -Obtaining ------------ - -The latest version is available (BSD license) at -[GitHub](https://github.com/madhadron/hdaemonize). - -Using -------- - -The synopsis is: - - import System.Posix.Daemonize - main = daemonize $ program - -This code will make `program` do what good daemons should do, that is, -detach from the terminal, close file descriptors, create a new process -group, and so on. - -If you want more functionality than that, it is available as a -`serviced` function. - -Here is an example: - - import Control.Concurrent - import System.Posix.Daemonize - - loop i log = do threadDelay $ 10^6 - log (show i) - writeFile "/tmp/counter" $ show i - if i == 5 then undefined else loop (i + 1) log - - main = serviced (loop 0) - -Let us say this program is compiled as `mydaemon`. Then: - - # mydaemon start - -starts the service. A second call to start will complain that the -program is already running. - -During its execution, mydaemon will simply write a new number to -`/tmp/counter` every second, until it reaches 5. Then, an exception -will be thrown. This exception will be caught by `hdaemonize`, and -logged to `/var/log/daemon.log` or similar (this is depends on how -`syslog` works on your platorm). `log (show i)` will leave messages -in the same file. - -When the exception is thrown, the program will be restared in 5 -seconds, and will start counting from 0 again. - -The following commands are also made available: - - # mydaemon stop - # mydaemon restart - -Finally, `mydaemon` drops privileges. By default it changes the -effective user and group ids to those of the `daemon` user, but it -prefers to use those of `mydaemon`, if present. - - -Changelog ---------- - -* 0.4 - * added support for a privileged action before dropping privileges - -* 0.3 - * merged with updates by madhadron - -* 0.2 - * provided documentation - * backported to older GHC versions, tested on 6.8.1 - -* 0.1 - * initial public release - - -Authors -------- - -Anton Tayanovskyy , bug reports and feature -requests welcome. - -The code is originally based on a public posting by -[Andre Nathan](http://sneakymustard.com/), used by permission. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,116 @@ +`hdaemonize` +================= +[![Build Status](https://travis-ci.org/unprolix/hdaemonize.svg?branch=master)](https://travis-ci.org/unprolix/hdaemonize) + +`hdaemonize` is a simple library that hides some of the complexities +of writing UNIX daemons in Haskell. + +Obtaining +----------- + +The latest version is available (BSD license) at +[GitHub](https://github.com/unprolix/hdaemonize). + +Using +------- + +The synopsis is: + + import System.Posix.Daemonize + main = daemonize $ program + +This code will make `program` do what good daemons should do, that is, +detach from the terminal, close file descriptors, create a new process +group, and so on. + +If you want more functionality than that, it is available as a +`serviced` function. + +Here is an example: + + import Control.Concurrent + import System.Posix.Daemonize + + loop i log = do threadDelay $ 10^6 + log (show i) + writeFile "/tmp/counter" $ show i + if i == 5 then undefined else loop (i + 1) log + + main = serviced (loop 0) + +Let us say this program is compiled as `mydaemon`. Then: + + # mydaemon start + +starts the service. A second call to start will complain that the +program is already running. + +During its execution, mydaemon will simply write a new number to +`/tmp/counter` every second, until it reaches 5. Then, an exception +will be thrown. This exception will be caught by `hdaemonize`, and +logged to `/var/log/daemon.log` or similar (this is depends on how +`syslog` works on your platorm). `log (show i)` will leave messages +in the same file. + +When the exception is thrown, the program will be restared in 5 +seconds, and will start counting from 0 again. + +The following commands are also made available: + + # mydaemon stop + # mydaemon restart + +Finally, if configured to do so, `mydaemon` drops privileges by +changing its effective user/group ID. (If no user/group ID are +specified, it will continue execution as the original user and group.) + +Note that if you wish to parse your own commandline arguments, you can +replace invocation of the `serviced` function with `serviced'`. This +requires specification of an `Operation` which indicates whether the +daemon should be started, stopped, restarted, or whether its status +should be queried. + +Changelog +--------- + +* 0.5.6 + * Add `serviced'` function and `Operation` (`Start`, `Stop`, etc.) to allow invocation separated from commandline + * Only attempt to change effective user/group ID when explicitly specified. + * Do not attempt to set user or group to the daemon's name in the absence of a specified user or group. + +* 0.5.5 + * Fix a bug where hdaemonize fails when user or group "daemon" is absent + +* 0.5.4 + * Update to use hsyslog == 5. + +* 0.5.2 + * Fix pre-AMP builds. + +* 0.5.1 + * Updated to use hsyslog >=4 + +* 0.4 + * added support for a privileged action before dropping privileges + +* 0.3 + * merged with updates by madhadron + +* 0.2 + * provided documentation + * backported to older GHC versions, tested on 6.8.1 + +* 0.1 + * initial public release + + +Authors +------- +Jeremy Bornstein + +Lana Black + +Anton Tayanovskyy . + +The code is originally based on a public posting by +[Andre Nathan](http://sneakymustard.com/), used by permission. diff --git a/System/Posix/Daemonize.hs b/System/Posix/Daemonize.hs --- a/System/Posix/Daemonize.hs +++ b/System/Posix/Daemonize.hs @@ -1,50 +1,22 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module System.Posix.Daemonize ( -- * Simple daemonization - daemonize, + daemonize, -- * Building system services - serviced, CreateDaemon(..), simpleDaemon, - -- * Intradaemon utilities - fatalError, exitCleanly - -- * An example - -- - -- | Here is an example of a full program which writes a message to - -- syslog once a second proclaiming its continued existance, and - -- which installs its own SIGHUP handler. Note that you won't - -- actually see the message once a second in the log on most - -- systems. @syslogd@ detects repeated messages and prints the - -- first one, then delays for the rest and eventually writes a line - -- about how many times it has seen it. - -- - -- > module Main where - -- > - -- > import System.Posix.Daemonize (CreateDaemon(..), serviced, simpleDaemon) - -- > import System.Posix.Signals (installHandler, Handler(Catch), sigHUP, fullSignalSet) - -- > import System.Posix.Syslog (syslog, Priority(Notice)) - -- > import Control.Concurrent (threadDelay) - -- > import Control.Monad (forever) - -- > - -- > main :: IO () - -- > main = serviced stillAlive - -- > - -- > stillAlive :: CreateDaemon () - -- > stillAlive = simpleDaemon { program = stillAliveMain } - -- > - -- > stillAliveMain :: () -> IO () - -- > stillAliveMain _ = do - -- > installHandler sigHUP (Catch taunt) (Just fullSignalSet) - -- > forever $ do threadDelay (10^6) - -- > syslog Notice "I'm still alive!" - -- > - -- > taunt :: IO () - -- > taunt = syslog Notice "I sneeze in your general direction, you and your SIGHUP." - + serviced, serviced', CreateDaemon(..), simpleDaemon, Operation(..), + -- * Intradaemon utilities + fatalError, exitCleanly, + -- * Logging utilities + syslog ) where - -{- originally based on code from + +{- 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) @@ -55,50 +27,61 @@ 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 -import System.Posix.Syslog (withSyslog,Option(..),Priority(..),Facility(..),syslog) +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) -import Data.Maybe (isNothing, fromMaybe, fromJust) +data Operation = Start | Stop | Restart | Status deriving (Eq, Show) +syslog :: Priority -> ByteString -> IO () +syslog pri msg = unsafeUseAsCStringLen msg (Log.syslog (Just Daemon) 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 program = - - do setFileCreationMask 0 - forkProcess p - exitImmediately ExitSuccess - +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 + program @@ -106,9 +89,9 @@ -- | '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 @@ -124,9 +107,9 @@ -- 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@. @@ -134,51 +117,87 @@ -- 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 daemon = do - systemName <- getProgName - let daemon' = daemon { name = if isNothing (name daemon) - then Just systemName else name daemon } - args <- getArgs - process daemon' args +serviced daemon = do + args <- getArgs + + let mOperation :: Maybe Operation + mOperation = case args of + ("start" : _) -> Just Start + ("stop" : _) -> Just Stop + ("restart" : _) -> Just Restart + ("status" : _) -> Just Status + _ -> Nothing + + if isNothing mOperation + then getProgName >>= \pname -> putStrLn $ "usage: " ++ pname ++ " {start|stop|status|restart}" + else serviced' daemon $ fromJust mOperation + +serviced' :: CreateDaemon a -> Operation -> IO () +serviced' daemon operation = do + systemName <- getProgName + let daemon' = daemon { name = if isNothing (name daemon) + then Just systemName else name daemon } + process daemon' operation where - - program' daemon = withSyslog (fromJust $ name daemon) (syslogOptions daemon) DAEMON $ + 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 + forever $ program daemon privVal - process daemon ["start"] = pidExists daemon >>= f where + 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"] = + + process daemon Stop = do pid <- pidRead daemon - let ifdo x f = x >>= \x -> if x then f else pass case pid of Nothing -> pass - Just pid -> - (do signalProcess sigTERM pid - usleep (10^6) - ifdo (pidLive pid) $ - do usleep (3*10^6) - ifdo (pidLive pid) (signalProcess sigKILL pid)) + 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 _ _ = - getProgName >>= \pname -> putStrLn $ "usage: " ++ pname ++ " {start|stop|restart}" + 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." + + -- 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 secs pid = + whenM (pidLive pid) $ + if maybe True (> 0) secs + then do usleep (10^6) + wait (fmap (\x->x-1) secs) pid + else signalProcess sigKILL pid + +-- | A monadic-conditional version of the "when" guard (copied from shelly.) +whenM :: Monad m => m Bool -> m () -> m () +whenM c a = c >>= \res -> when res 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 @@ -213,17 +232,20 @@ -- the user field. syslogOptions :: [Option], -- ^ The options the daemon should set on -- syslog. You can safely leave this as @[]@. - 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'. + 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'. + 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 --- +-- | The simplest possible instance of 'CreateDaemon' is +-- -- > CreateDaemon { -- > privilegedAction = return () -- > program = const $ forever $ return () @@ -233,7 +255,7 @@ -- > 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. @@ -246,60 +268,78 @@ syslogOptions = [], pidfileDirectory = Nothing, program = const $ M.forever $ return (), - privilegedAction = return () + privilegedAction = return (), + killWait = Just 4 } - + {- implementation -} forever :: IO () -> IO () -forever program = +forever program = program `catch` restart where - restart :: SomeException -> IO () - restart e = - do syslog Error ("unexpected exception: " ++ show e) + 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 = +closeFileDescriptors = +#if MIN_VERSION_unix(2,8,0) + do null <- openFd "/dev/null" ReadWrite defaultFileFlags +#else do null <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags +#endif let sendTo fd' fd = closeFd fd >> dupTo fd' fd - mapM_ (sendTo null) $ [stdInput, stdOutput, stdError] + mapM_ (sendTo null) [stdInput, stdOutput, stdError] -blockSignal :: Signal -> IO () +blockSignal :: Signal -> IO () blockSignal sig = installHandler sig Ignore Nothing >> pass getGroupID :: String -> IO (Maybe GroupID) -getGroupID group = - try (fmap groupID (getGroupEntryForName group)) >>= return . f where +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 = - try (fmap userID (getUserEntryForName user)) >>= return . f where +getUserID user = + f <$> try (fmap userID (getUserEntryForName user)) + where f :: Either IOException UserID -> Maybe UserID f (Left _) = Nothing f (Right uid) = Just uid +-- only drop privileges if a user is specified 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 <- fmap (maybe ud id) $ getUserID targetUser - g <- fmap (maybe gd id) $ getGroupID targetGroup - setGroupID g - setUserID u +dropPrivileges daemon = do + case group daemon of + Nothing -> pure () + Just targetGroup -> do + mud <- getGroupID targetGroup + case mud of + Nothing -> do syslog Error "Privilege drop failure, could not identify specified group." + exitImmediately (ExitFailure 1) + undefined + Just gd -> setGroupID gd + case user daemon of + Nothing -> pure () + Just targetUser -> do + mud <- getUserID targetUser + case mud of + Nothing -> do syslog Error "Privilege drop failure, could not identify specified user." + exitImmediately (ExitFailure 1) + undefined + Just ud -> setUserID ud pidFile:: CreateDaemon a -> String -pidFile daemon = joinPath [dir, (fromJust $ name daemon) ++ ".pid"] +pidFile daemon = joinPath [dir, fromJust (name daemon) ++ ".pid"] where dir = fromMaybe "/var/run" (pidfileDirectory daemon) pidExists :: CreateDaemon a -> IO Bool @@ -307,7 +347,7 @@ pidRead :: CreateDaemon a -> IO (Maybe CPid) pidRead daemon = pidExists daemon >>= choose where - choose True = fmap (Just . read) $ readFile (pidFile daemon) + choose True = return . read <$> readFile (pidFile daemon) choose False = return Nothing pidWrite :: CreateDaemon a -> IO () @@ -316,12 +356,12 @@ writeFile (pidFile daemon) (show pid) pidLive :: CPid -> IO Bool -pidLive pid = +pidLive pid = (getProcessPriority pid >> return True) `catch` f where f :: IOException -> IO Bool f _ = return False - -pass :: IO () + +pass :: IO () pass = return () -- | When you encounter an error where the only sane way to handle it @@ -330,7 +370,7 @@ -- configuration files on startup. fatalError :: MonadIO m => String -> m a fatalError msg = liftIO $ do - syslog Error $ "Terminating from error: " ++ msg + syslog Error $ ByteString.pack $ "Terminating from error: " ++ msg exitImmediately (ExitFailure 1) undefined -- You will never reach this; it's there to make the type checker happy diff --git a/hdaemonize.cabal b/hdaemonize.cabal --- a/hdaemonize.cabal +++ b/hdaemonize.cabal @@ -1,27 +1,37 @@ Name: hdaemonize -Version: 0.4.5.0 -Cabal-Version: >= 1.6 +Version: 0.5.7 +Cabal-Version: >= 1.10 License: BSD3 License-file: LICENSE -Author: Anton Tayanovskyy, Fred Ross -Maintainer: Fred Ross -Homepage: http://github.com/madhadron/hdaemonize +Author: Anton Tayanovskyy, Fred Ross, Lana Black +Maintainer: Jeremy Bornstein +Homepage: http://github.com/unprolix/hdaemonize Category: System Synopsis: Library to handle the details of writing daemons for UNIX -Description: Provides two functions that help writing better UNIX daemons, - daemonize and serviced: daemonize does what a daemon should do - (forking and closing descriptors), while serviced does that and - more (syslog interface, PID file writing, start-stop-restart - command line handling, dropping privileges). +Description: Provides functions that help writing better UNIX daemons, + daemonize and serviced/serviced': daemonize does what + a daemon should do (forking and closing descriptors), + while serviced does that and more (syslog interface, + PID file writing, start-stop-restart command line + handling, dropping privileges). Build-Type: Simple -Extra-Source-Files: README +Extra-Source-Files: README.md Library - Build-Depends: base >= 4 && < 5, unix, hsyslog, extensible-exceptions, filepath, mtl + Build-Depends: base >= 4 && < 5 + , bytestring + , unix + , hsyslog == 5.* + , extensible-exceptions + , filepath + , mtl + Default-Language: Haskell2010 Exposed-modules: System.Posix.Daemonize - Extensions: CPP if impl(ghc > 6.12) Ghc-Options: -Wall -fno-warn-unused-do-bind -fno-warn-type-defaults -fno-warn-name-shadowing else Ghc-Options: -Wall -fno-warn-type-defaults -fno-warn-name-shadowing +source-repository head + type: git + location: https://github.com/unprolix/hdaemonize.git