diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, David Fisher + +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 David Fisher nor the names of other + 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.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +#Haskell implementation for systemd + +Systemd offers some functionnalities to developpers for creating daemons process + + +- Whatchdog (http://www.freedesktop.org/software/systemd/man/sd_notify.html) +- Socket activation (http://0pointer.de/blog/projects/socket-activation.html) +- journal log + +Available on hackage +http://hackage.haskell.org/package/systemd-1.0.0/docs/System-Systemd-Daemon.html diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Systemd/Daemon.hs b/System/Systemd/Daemon.hs new file mode 100644 --- /dev/null +++ b/System/Systemd/Daemon.hs @@ -0,0 +1,216 @@ +{-# 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 : experimental +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 + , notifyWatchdog + , notifyReady + , notifyPID + , notifyErrno + , notifyStatus + , notifyBusError + -- * Socket activation functions + , getActivatedSockets + -- * Utils + , unsetEnvironnement + ) where + + +import Control.Applicative +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 System.Posix.Env +import System.Posix.Process +import System.Posix.Types (CPid (..)) + +import Network.Socket hiding (recv, recvFrom, send, 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 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 + +-- | 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"] + +-- | 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 = 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 $ sendTo socketFd (BC.pack state) (SockAddrUnix socketPath') + 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 = runMaybeT $ do + listenPid <- read <$> MaybeT (getEnv "LISTEN_PID") + listenFDs <- read <$> MaybeT (getEnv "LISTEN_FDS") + myPid <- liftIO getProcessID + guard $ listenPid == myPid + mapM makeSocket [fdStart .. fdStart + listenFDs - 1] + where makeSocket :: CInt -> MaybeT IO Socket + makeSocket fd = do + fam <- socketFamily fd + typ <- socketType fd + stat <- socketStatus fd + liftIO $ mkSocket fd fam typ defaultProtocol stat + +socketFamily :: CInt -> MaybeT IO Family +socketFamily fd = do + familyInt <- liftIO $ c_socket_family fd + guard $ familyInt >= 0 + return $ unpackFamily familyInt + +socketType :: CInt -> MaybeT IO SocketType +socketType fd = do + typeInt <- liftIO $ c_socket_type fd + case typeInt of + 0 -> return NoSocketType + 1 -> return Stream + 2 -> return Datagram + 3 -> return Raw + 4 -> return RDM + 5 -> return SeqPacket + _ -> mzero + +socketStatus :: CInt -> MaybeT IO SocketStatus +socketStatus fd = do + listeningInt <- liftIO $ c_socket_listening fd + case listeningInt of + 0 -> return Bound + 1 -> return Listening + _ -> mzero + +foreign import ccall unsafe "socket_family" + c_socket_family :: CInt -> IO CInt + +foreign import ccall unsafe "socket_type" + c_socket_type :: CInt -> IO CInt + +foreign import ccall unsafe "socket_listening" + c_socket_listening :: CInt -> IO CInt diff --git a/System/Systemd/socket_info.c b/System/Systemd/socket_info.c new file mode 100644 --- /dev/null +++ b/System/Systemd/socket_info.c @@ -0,0 +1,34 @@ +#include + +int socket_family(int fd) { + struct sockaddr sockaddr = {}; + socklen_t len = sizeof(sockaddr); + + if (getsockname(fd, &sockaddr, &len) < 0) + return -1; + + if (len < sizeof(sa_family_t)) + return -1; + + return sockaddr.sa_family; +} + +int socket_type(int fd) { + int type = 0; + socklen_t len = sizeof(type); + + if (getsockopt(fd, SOL_SOCKET, SO_TYPE, &type, &len) < 0) + return -1; + + return type; +} + +int socket_listening(int fd) { + int accepting = 0; + socklen_t len = sizeof(accepting); + + if (getsockopt(fd, SOL_SOCKET, SO_ACCEPTCONN, &accepting, &len) < 0) + return -1; + + return accepting; +} diff --git a/systemd.cabal b/systemd.cabal new file mode 100644 --- /dev/null +++ b/systemd.cabal @@ -0,0 +1,40 @@ +-- Initial systemd.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: systemd +version: 0.1.0.1 +synopsis: Systemd facilities (Socket activation, Notify) +description: A module for Systemd facilities. +homepage: https://github.com/erebe/systemd +license: BSD3 +license-file: LICENSE +author: Erèbe +maintainer: romain.gerard@erebe.eu + +category: System +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/erebe/systemd + +library + exposed-modules: System.Systemd.Daemon + c-sources: System/Systemd/socket_info.c + build-depends: base >=4.7 && <= 4.8.1.0, + unix >= 2.5, + transformers >= 0.3, + network >=2.3, + bytestring >= 0.10 + + default-language: Haskell2010 + +test-suite daemon-test + hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: Main.hs + default-language: Haskell2010 + build-depends: base >=4.7 && <= 4.8.1.0, + systemd + default-language: Haskell2010 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,15 @@ + +import System.Systemd.Daemon +import Control.Monad +import Control.Concurrent + + + +main :: IO () +main = forever runner + where + runner = do + res <- notifyWatchdog + print res + threadDelay $ 1000000 * 2 +