diff --git a/System/Systemd/Daemon.hs b/System/Systemd/Daemon.hs --- a/System/Systemd/Daemon.hs +++ b/System/Systemd/Daemon.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ForeignFunctionInterface #-} {-| Module : System.Systemd.Daemon Description : Systemd facilities to manage daemons @@ -12,6 +11,11 @@ Implementation of Systemd facilities to create and manage daemons. +All socket-related actions in this module, work with the +"Network.Socket" module from @network@. If you want to use +a different socket library or work directly with file +descriptors, see "System.Systemd.Daemon.Fd". + This module contains socket activation and notify tools. See * @@ -71,33 +75,15 @@ , 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 qualified System.Systemd.Daemon.Fd as Fd +import System.Systemd.Internal -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 Foreign.C.Error (Errno (..)) +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" @@ -140,7 +126,7 @@ -- -- Usefull for zero downtime restart storeFd :: Socket -> IO (Maybe ()) -storeFd = notifyWithFD False "FDSTORE=1" +storeFd sock = socketToFd sock >>= Fd.storeFd -- | Notify systemd to store a socket for us and specify a name. -- @@ -148,13 +134,7 @@ -- -- 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"] +storeFdWithName sock name = socketToFd sock >>= flip Fd.storeFdWithName name -- | Notify systemd about an event -- @@ -173,50 +153,12 @@ -- 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 () - - - - +notifyWithFD unset_env state sock = socketToFd sock >>= Fd.notifyWithFD unset_env state ------------------------------------------------------------------------------------------------ -- SOCKET ------------------------------------------------------------------------------------------------ -fdStart :: CInt -fdStart = 3 - -- | Return a list of activated sockets, if the program was started with -- socket activation. -- @@ -226,7 +168,7 @@ -- Returns 'Nothing' in systems without socket activation (or -- when the program was not socket activated). getActivatedSockets :: IO (Maybe [Socket]) -getActivatedSockets = fmap (fmap fst) <$> getActivatedSocketsWithNames +getActivatedSockets = Fd.getActivatedSockets >>= traverse (mapM fdToSocket) -- | Same as 'getActivatedSockets' but return also the names associated -- with those sockets if 'storeFdWithName' was used or specified in the @.socket@ file. @@ -234,35 +176,5 @@ -- 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 +getActivatedSocketsWithNames = Fd.getActivatedSocketsWithNames >>= traverse (mapM socketWithName) + where socketWithName (fd, name) = fmap (flip (,) name) $ fdToSocket fd diff --git a/System/Systemd/Daemon/Fd.hs b/System/Systemd/Daemon/Fd.hs new file mode 100644 --- /dev/null +++ b/System/Systemd/Daemon/Fd.hs @@ -0,0 +1,115 @@ +{-| +Module : System.Systemd.Daemon.Fd +Description : File descriptor based socket activation/management + using systemd +Copyright : (c) Romain Gérard, 2014 + David Fisher, 2013 + Lukas Epple, 2019 +License : BSD3 +Maintainer : romain.gerard@erebe.eu +Stability : stable +Portability : Requires Systemd or will fail otherwise + +This module implements all functions from "System.Systemd.Daemon" +that require or return 'Network.Socket.Socket's purely using 'Fd's. +This is especially useful if you have to do low level IO using +file descriptors or use a different socket library than @network@. + +The API is exactly the same as "System.Systemd.Daemon" except that +'Network.Socket.Socket's have been replaced by 'Fd's (actually +"System.Systemd.Daemon" uses this module internally). This also means +that "System.Systemd.Daemon.Fd" and "System.Systemd.Daemon" expose +conflicting functions. You either have to import "System.Systemd.Daemon.Fd" +@qualified@ or like so: + +@ +import System.Systemd.Daemon hiding ( notifyWithFD, storeFd + , storeFdWithName + , getActivatedSockets + , getActivatedSocketsWithNames ) +import System.Systemd.Daemon.Fd +@ + +The functions in "System.Systemd.Daemon" that are not implemented +in this module are 100% compatible with "System.Systemd.Daemon.Fd". +-} +module System.Systemd.Daemon.Fd + ( -- * Notify functions + notifyWithFD + , storeFd + , storeFdWithName + -- * Socket activation functions + , getActivatedSockets + , getActivatedSocketsWithNames + ) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe +import qualified Data.ByteString.Char8 as BC +import Foreign.C.Types (CInt (..)) +import Network.Socket (setNonBlockIfNeeded) +import System.Posix.Env (getEnv) +import System.Posix.Process +import System.Posix.Types (Fd (..)) +import System.Systemd.Internal + +fdStart :: CInt +fdStart = 3 + +-- | Notify Systemd to store a file descriptor for us. This together +-- with 'getActivatedSockets' allows for zero downtime +-- restarts and socket activation. +-- +-- Equivalent to standard 'System.Systemd.Daemon.storeFd' +storeFd :: Fd -> IO (Maybe ()) +storeFd = notifyWithFD False "FDSTORE=1" + +-- | Like 'storeFd', but associate the file descriptor with a name. +-- Best used along with 'getActivatedSocketsWithNames'. +-- +-- Equivalent to standard 'System.Systemd.Daemon.storeFdWithName' +storeFdWithName :: Fd -> String -> IO (Maybe ()) +storeFdWithName fd name = notifyWithFD False ("FDSTORE=1\nFDNAME=" ++ name) fd + +-- | Same as 'System.Systemd.Daemon.notify', but send along a 'Fd'. +-- Note that the caller must set the message, i. e. send @FDSTORE=1@ +-- to actually store the file descriptor. In most cases it is probably best +-- to use 'storeFd' or the notify-functions from "System.Systemd.Daemon". +-- +-- Equivalent to standard 'System.Systemd.Daemon.notifyWithFD'. +notifyWithFD :: Bool -> String -> Fd -> IO (Maybe ()) +notifyWithFD unset_env state sock = notifyWithFD_ unset_env state (Just sock) + +-- | Return 'Just' a list of file descriptors if the current process +-- has been activated with one or more socket by systemd, 'Nothing' +-- otherwise. +-- +-- The file descriptors are in the same order as the sockets in the +-- associated @.socket@ file. The sockets will have their family, type, +-- and status set according to the @.socket@ file. +-- +-- Equivalent to standard 'System.Systemd.Daemon.getActivatedSockets' +getActivatedSockets :: IO (Maybe [Fd]) +getActivatedSockets = fmap (fmap fst) <$> getActivatedSocketsWithNames + +-- | Like 'getActivatedSockets', but also return the associated names. +-- If a file descriptor has no associated name, it will be a generic +-- one set by systemd. +-- +-- Equivalent to standard 'System.Systemd.Daemon.getActivatedSocketsWithNames' +getActivatedSocketsWithNames :: IO (Maybe [(Fd, 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 + nonBlockFds <- mapM (\fd -> liftIO (setNonBlockIfNeeded fd) >> pure (Fd fd)) + [fdStart .. fdStart + listenFDs - 1] + guard $ length nonBlockFds == length listenFDNames' + + return $ zip nonBlockFds listenFDNames' diff --git a/System/Systemd/Internal.hs b/System/Systemd/Internal.hs new file mode 100644 --- /dev/null +++ b/System/Systemd/Internal.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module System.Systemd.Internal where + +import Control.Exception (bracket) +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe +import qualified Data.ByteString.Char8 as BC +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.List +import Foreign.C.Types (CInt (..)) +import Foreign.Marshal (free, mallocBytes) +import Foreign.Ptr +import Network.Socket +import Network.Socket.Address hiding (recvFrom, sendTo) +import Network.Socket.ByteString +import System.Posix.Env +import System.Posix.Types (Fd (..)) + +envVariableName :: String +envVariableName = "NOTIFY_SOCKET" + +foreign import ccall unsafe "sd_notify_with_fd" + c_sd_notify_with_fd :: CInt -> Ptr a -> CInt -> Ptr b -> CInt -> CInt -> IO CInt + +-- | Unset all environnement variable related to Systemd. +-- +-- Calls to functions like 'System.Systemd.Daemon.notify' and +-- 'System.Systemd.Daemon.getActivatedSockets' will return +-- 'Nothing' after that. +unsetEnvironnement :: IO () +unsetEnvironnement = mapM_ unsetEnv [envVariableName, "LISTEN_PID", "LISTEN_FDS", "LISTEN_FDNAMES"] + +sendBufWithFdTo :: Socket -> BC.ByteString -> SockAddr -> Fd -> IO Int +sendBufWithFdTo sock state addr fdToSend = + unsafeUseAsCStringLen state $ \(ptr, nbytes) -> + bracket addrPointer free $ \p_addr -> do + fd <- socketToFd sock + fromIntegral <$> c_sd_notify_with_fd (fromIntegral fd) ptr (fromIntegral nbytes) + p_addr (fromIntegral addrSize) (fromIntegral fdToSend) + where addrSize = sizeOfSocketAddress addr + addrPointer = mallocBytes addrSize >>= (\ptr -> pokeSocketAddress ptr addr >> pure ptr) + +notifyWithFD_ :: Bool -> String -> Maybe Fd -> IO (Maybe ()) +notifyWithFD_ unset_env state fd = 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 fd 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 () + +socketToFd :: Socket -> IO Fd +socketToFd = fmap Fd . fdSocket + +fdToSocket :: Fd -> IO Socket +fdToSocket = mkSocket . fromIntegral diff --git a/systemd.cabal b/systemd.cabal --- a/systemd.cabal +++ b/systemd.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: systemd -version: 2.0.0 +version: 2.1.0 synopsis: Systemd facilities (Socket activation, Notify) description: A module for Systemd facilities. homepage: https://github.com/erebe/systemd @@ -23,6 +23,8 @@ library ghc-options: -Wall exposed-modules: System.Systemd.Daemon + , System.Systemd.Daemon.Fd + other-modules: System.Systemd.Internal c-sources: System/Systemd/socket_info.c build-depends: base == 4.* , unix >= 2.5,