diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2009, Anton Tayanovskyy +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + * Neither the name of Anton Tayanovskyy nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,91 @@ +`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/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/System/Posix/Daemonize.hs b/System/Posix/Daemonize.hs new file mode 100644 --- /dev/null +++ b/System/Posix/Daemonize.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE RankNTypes #-} +module System.Posix.Daemonize ( + -- * Simple daemonization + 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." + + ) where + +{- originally based on code from + http://sneakymustard.com/2008/12/11/haskell-daemons -} + + +import Control.Monad.Trans +import Control.Exception.Extensible +import qualified Control.Monad as M (forever) +import Prelude hiding (catch) +import System.Exit (ExitCode(..)) +import System.Environment (getArgs, getProgName) +import System.Posix +import System.Posix.Syslog (withSyslog,Option(..),Priority(..),Facility(..),syslog) +import System.FilePath.Posix (joinPath) +import Data.Maybe (isNothing, fromMaybe, fromJust) + + +-- | 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 + + where + + p = do createSession + forkProcess p' + exitImmediately ExitSuccess + + p' = do changeWorkingDirectory "/" + closeFileDescriptors + blockSignal sigHUP + 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 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 + 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)) + `finally` + removeLink (pidFile daemon) + + process daemon ["restart"] = do process daemon ["stop"] + process daemon ["start"] + process _ _ = + getProgName >>= \pname -> putStrLn $ "usage: " ++ pname ++ " {start|stop|restart}" + +-- | 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 { + privilegedAction :: IO a, -- ^ An action to be run as root, before + -- permissions are dropped, e.g., binding + -- a trusted port. + 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. + 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. + 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@. + group :: Maybe String, -- ^ 'group' is the group the daemon should + -- try to run as, and works the same way as + -- 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'. +} + +-- | 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 { + name = Nothing, + user = Nothing, + group = Nothing, + syslogOptions = [], + pidfileDirectory = Nothing, + program = const $ M.forever $ return (), + privilegedAction = return () +} + + + + +{- implementation -} + +forever :: IO () -> IO () +forever program = + program `catch` restart where + restart :: SomeException -> IO () + restart e = + do syslog Error ("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 = + try (fmap groupID (getGroupEntryForName group)) >>= return . f 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 + 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 <- fmap (maybe ud id) $ getUserID targetUser + g <- fmap (maybe gd id) $ 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 = fmap (Just . 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 () + +-- | 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 msg = liftIO $ do + syslog Error $ "Terminating from error: " ++ msg + exitImmediately (ExitFailure 1) + 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 = liftIO $ do + syslog Notice "Exiting." + exitImmediately ExitSuccess + undefined -- You will never reach this; it's there to make the type checker happy diff --git a/hdaemonize-buildfix.cabal b/hdaemonize-buildfix.cabal new file mode 100644 --- /dev/null +++ b/hdaemonize-buildfix.cabal @@ -0,0 +1,26 @@ +Name: hdaemonize-buildfix +Version: 0.4.5 +Cabal-Version: >= 1.6 +License: BSD3 +License-file: LICENSE +Author: Anton Tayanovskyy, Fred Ross +Maintainer: Fred Ross , Mark Wotton (trivial buildfix only) +Homepage: http://github.com/madhadron/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). +Build-Type: Simple +Extra-Source-Files: README + +Library + Build-Depends: base >= 4 && < 5, unix, hsyslog, extensible-exceptions, filepath, mtl + Exposed-modules: System.Posix.Daemonize + 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 +