{-# LANGUAGE ForeignFunctionInterface #-} {-| Module : System.Systemd.Daemon Description : Systemd facilities to manage daemons Copyright : (c) Romain Gérard, 2014 David Fisher, 2013 License : BSD3 Maintainer : romain.gerard@erebe.eu Stability : stable Portability : Require Systemd or will fail otherwise Implementation of Systemd facilities to create and manage daemons. This module contains socket activation and notify tools. See * * * Example: @ import Control.Monad(forever) import System.Systemd.Daemon(notifyWatchdog) main :: IO () main = forever $ do functionThatMayHang notifyWatchdog @ If you use the service described as below, Systemd will restart your program each time the watchdog fail to notify itself under 60 sec. @ [Unit] Description=MyDaemon [Service] Type=simple TimeoutStartSec=0 ExecStart=AbsolutePathToMyExecutable WatchdogSec=60 Restart=on-failure [Install] WantedBy=multi-user.target @ -} module System.Systemd.Daemon ( -- * Notify functions notify , notifyWithFD , storeFd , storeFdWithName , notifyWatchdog , notifyReady , notifyPID , notifyErrno , notifyStatus , notifyBusError , notifyReloading , notifyStopping -- * Socket activation functions , getActivatedSockets , getActivatedSocketsWithNames -- * Utils , unsetEnvironnement ) where import Control.Exception (bracket) import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe import Data.List import qualified Data.ByteString.Char8 as BC import Foreign.C.Error (Errno (..)) import Foreign.C.Types (CInt (..)) import Foreign.Marshal (free, mallocBytes) import Foreign.Ptr import System.Posix.Env import System.Posix.Process import System.Posix.Types (CPid (..)) import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Network.Socket import Network.Socket.Address hiding (recvFrom, sendTo) import Network.Socket.ByteString envVariableName :: String envVariableName = "NOTIFY_SOCKET" -- | Notify the watchdog that the program is still alive notifyWatchdog :: IO (Maybe()) notifyWatchdog = notify False "WATCHDOG=1" -- | Notify the systemd that the program is ready notifyReady :: IO (Maybe()) notifyReady = notify False "READY=1" -- | Notify systemd of the PID of the program (for after a fork) notifyPID :: CPid -> IO (Maybe()) notifyPID pid = notify False $ "MAINPID=" ++ show pid -- | Notify systemd that the service is reloading its configuration notifyReloading :: IO (Maybe()) notifyReloading = notify False "RELOADING=1" -- | Notify systemd that the service is beginning its shutdown notifyStopping :: IO (Maybe()) notifyStopping = notify False "STOPPING=1" -- | Notify systemd of an 'Errno' error notifyErrno :: Errno -> IO (Maybe()) notifyErrno (Errno errorNb) = notify False $ "ERRNO=" ++ show errorNb -- | Notify systemd of the status of the program. -- -- An arbitrary 'String' can be passed notifyStatus :: String -> IO (Maybe()) notifyStatus msg = notify False $ "STATUS=" ++ msg -- | Notify systemd of a DBUS error like. -- -- Correct formatting of the 'String' is left to the caller notifyBusError :: String -> IO (Maybe()) notifyBusError msg = notify False $ "BUSERROR=" ++ msg -- | Notify systemd to store a socket for us. -- -- To be used along 'getActivatedSockets' during a restart -- -- Usefull for zero downtime restart storeFd :: Socket -> IO (Maybe ()) storeFd = notifyWithFD False "FDSTORE=1" -- | Notify systemd to store a socket for us and specify a name. -- -- To be used along 'getActivatedSocketsWithNames' during a restart -- -- Usefull for zero downtime restart storeFdWithName :: Socket -> String -> IO (Maybe ()) storeFdWithName sock name = notifyWithFD False ("FDSTORE=1\nFDNAME=" ++ name) sock -- | Unset all environnement variable related to Systemd. -- -- Calls to 'notify' like and 'getActivatedSockets' functions will return 'Nothing' after that unsetEnvironnement :: IO () unsetEnvironnement = mapM_ unsetEnv [envVariableName, "LISTEN_PID", "LISTEN_FDS", "LISTEN_FDNAMES"] -- | Notify systemd about an event -- -- After notifying systemd the 'Bool' parameter specify if the environnement -- shall be unset (Further call to notify will fail) -- -- The 'String' is the event to pass -- -- Returns 'Nothing' if the program was not started with systemd -- or that the environnement was previously unset notify :: Bool -> String -> IO (Maybe ()) notify unset_env state = notifyWithFD_ unset_env state Nothing -- | Same as 'notify' but send along a socket to be stored -- -- It is up to the caller to properly set the message -- (i.e: do not forget to set FDSTORE=1) notifyWithFD :: Bool -> String -> Socket -> IO (Maybe ()) notifyWithFD unset_env state sock = notifyWithFD_ unset_env state (Just sock) notifyWithFD_ :: Bool -> String -> Maybe Socket -> IO (Maybe ()) notifyWithFD_ unset_env state sock = do res <- runMaybeT notifyImpl when unset_env unsetEnvironnement return res where isValidPath path = (length path >= 2) && ( "@" `isPrefixOf` path || "/" `isPrefixOf` path) notifyImpl = do guard $ state /= "" socketPath <- MaybeT (getEnv envVariableName) guard $ isValidPath socketPath let socketPath' = if head socketPath == '@' -- For abstract socket then '\0' : tail socketPath else socketPath socketFd <- liftIO $ socket AF_UNIX Datagram 0 nbBytes <- liftIO $ case sock of Nothing -> sendTo socketFd (BC.pack state) (SockAddrUnix socketPath') Just sock' -> sendBufWithFdTo socketFd (BC.pack state) (SockAddrUnix socketPath') sock' liftIO $ close socketFd guard $ nbBytes >= length state return () ------------------------------------------------------------------------------------------------ -- SOCKET ------------------------------------------------------------------------------------------------ fdStart :: CInt fdStart = 3 -- | Return a list of activated sockets, if the program was started with -- socket activation. -- -- The sockets are in the same order as in the associated @.socket@ file. -- The sockets will have their family, type, and status set appropriately. -- -- Returns 'Nothing' in systems without socket activation (or -- when the program was not socket activated). getActivatedSockets :: IO (Maybe [Socket]) getActivatedSockets = fmap (fmap fst) <$> getActivatedSocketsWithNames -- | Same as 'getActivatedSockets' but return also the names associated -- with those sockets if 'storeFdWithName' was used or specified in the @.socket@ file. -- -- IF 'storeFd' was used to transmit the socket to systemd, the name will be a generic one -- (i.e: usally "stored") getActivatedSocketsWithNames :: IO (Maybe [(Socket, String)]) getActivatedSocketsWithNames = runMaybeT $ do listenPid <- read <$> MaybeT (getEnv "LISTEN_PID") listenFDs <- read <$> MaybeT (getEnv "LISTEN_FDS") listenFDNames <- MaybeT (getEnv "LISTEN_FDNAMES") myPid <- liftIO getProcessID guard $ listenPid == myPid let listenFDNames' = fmap BC.unpack $ BC.split ':' $ BC.pack listenFDNames sockets <- mapM makeSocket [fdStart .. fdStart + listenFDs - 1] guard $ length sockets == length listenFDNames' return $ zip sockets listenFDNames' where makeSocket :: CInt -> MaybeT IO Socket makeSocket fd = liftIO $ do setNonBlockIfNeeded fd mkSocket fd sendBufWithFdTo :: Socket -> BC.ByteString -> SockAddr -> Socket -> IO Int sendBufWithFdTo sock state addr sockToSend = unsafeUseAsCStringLen state $ \(ptr, nbytes) -> bracket addrPointer free $ \p_addr -> do fd <- fdSocket sock fdToSend <- fdSocket sockToSend fromIntegral <$> c_sd_notify_with_fd fd ptr (fromIntegral nbytes) p_addr (fromIntegral addrSize) fdToSend where addrSize = sizeOfSocketAddress addr addrPointer = mallocBytes addrSize >>= (\ptr -> pokeSocketAddress ptr addr >> pure ptr) foreign import ccall unsafe "sd_notify_with_fd" c_sd_notify_with_fd :: CInt -> Ptr a -> CInt -> Ptr b -> CInt -> CInt -> IO CInt