{-# LANGUAGE ForeignFunctionInterface #-}
module System.Systemd.Daemon (
notify
, notifyWithFD
, storeFd
, storeFdWithName
, notifyWatchdog
, notifyReady
, notifyPID
, notifyErrno
, notifyStatus
, notifyBusError
, notifyReloading
, notifyStopping
, getActivatedSockets
, getActivatedSocketsWithNames
, 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"
notifyWatchdog :: IO (Maybe())
notifyWatchdog = notify False "WATCHDOG=1"
notifyReady :: IO (Maybe())
notifyReady = notify False "READY=1"
notifyPID :: CPid -> IO (Maybe())
notifyPID pid = notify False $ "MAINPID=" ++ show pid
notifyReloading :: IO (Maybe())
notifyReloading = notify False "RELOADING=1"
notifyStopping :: IO (Maybe())
notifyStopping = notify False "STOPPING=1"
notifyErrno :: Errno -> IO (Maybe())
notifyErrno (Errno errorNb) = notify False $ "ERRNO=" ++ show errorNb
notifyStatus :: String -> IO (Maybe())
notifyStatus msg = notify False $ "STATUS=" ++ msg
notifyBusError :: String -> IO (Maybe())
notifyBusError msg = notify False $ "BUSERROR=" ++ msg
storeFd :: Socket -> IO (Maybe ())
storeFd = notifyWithFD False "FDSTORE=1"
storeFdWithName :: Socket -> String -> IO (Maybe ())
storeFdWithName sock name = notifyWithFD False ("FDSTORE=1\nFDNAME=" ++ name) sock
unsetEnvironnement :: IO ()
unsetEnvironnement = mapM_ unsetEnv [envVariableName, "LISTEN_PID", "LISTEN_FDS", "LISTEN_FDNAMES"]
notify :: Bool -> String -> IO (Maybe ())
notify unset_env state = notifyWithFD_ unset_env state Nothing
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 == '@'
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 ()
fdStart :: CInt
fdStart = 3
getActivatedSockets :: IO (Maybe [Socket])
getActivatedSockets = fmap (fmap fst) <$> getActivatedSocketsWithNames
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