{-|
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 :: CInt
fdStart = CInt
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 :: Fd -> IO (Maybe ())
storeFd = Bool -> String -> Fd -> IO (Maybe ())
notifyWithFD Bool
False String
"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 -> String -> IO (Maybe ())
storeFdWithName Fd
fd String
name = Bool -> String -> Fd -> IO (Maybe ())
notifyWithFD Bool
False (String
"FDSTORE=1\nFDNAME=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) Fd
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 :: Bool -> String -> Fd -> IO (Maybe ())
notifyWithFD Bool
unset_env String
state Fd
sock = Bool -> String -> Maybe Fd -> IO (Maybe ())
notifyWithFD_ Bool
unset_env String
state (Fd -> Maybe Fd
forall a. a -> Maybe a
Just Fd
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 :: IO (Maybe [Fd])
getActivatedSockets = MaybeT IO [Fd] -> IO (Maybe [Fd])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO [Fd] -> IO (Maybe [Fd]))
-> MaybeT IO [Fd] -> IO (Maybe [Fd])
forall a b. (a -> b) -> a -> b
$ do
    ProcessID
listenPid     <- String -> ProcessID
forall a. Read a => String -> a
read (String -> ProcessID) -> MaybeT IO String -> MaybeT IO ProcessID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> IO (Maybe String)
getEnv String
"LISTEN_PID")
    CInt
listenFDs     <- String -> CInt
forall a. Read a => String -> a
read (String -> CInt) -> MaybeT IO String -> MaybeT IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> IO (Maybe String)
getEnv String
"LISTEN_FDS")

    ProcessID
myPid <- IO ProcessID -> MaybeT IO ProcessID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProcessID
getProcessID
    Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> Bool -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ ProcessID
listenPid ProcessID -> ProcessID -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessID
myPid

    (CInt -> MaybeT IO Fd) -> [CInt] -> MaybeT IO [Fd]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\CInt
fd -> IO () -> MaybeT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CInt -> IO ()
setNonBlockIfNeeded CInt
fd) MaybeT IO () -> MaybeT IO Fd -> MaybeT IO Fd
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> MaybeT IO Fd
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CInt -> Fd
Fd CInt
fd))
         [CInt
fdStart .. CInt
fdStart CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
+ CInt
listenFDs CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
- CInt
1]

-- | 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 :: IO (Maybe [(Fd, String)])
getActivatedSocketsWithNames = MaybeT IO [(Fd, String)] -> IO (Maybe [(Fd, String)])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO [(Fd, String)] -> IO (Maybe [(Fd, String)]))
-> MaybeT IO [(Fd, String)] -> IO (Maybe [(Fd, String)])
forall a b. (a -> b) -> a -> b
$ do
    String
listenFDNames <- IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> IO (Maybe String)
getEnv String
"LISTEN_FDNAMES")
    let listenFDNames' :: [String]
listenFDNames' = (ByteString -> String) -> [ByteString] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> String
BC.unpack ([ByteString] -> [String]) -> [ByteString] -> [String]
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
BC.split Char
':' (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack String
listenFDNames

    [Fd]
nonBlockFds <- IO (Maybe [Fd]) -> MaybeT IO [Fd]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT IO (Maybe [Fd])
getActivatedSockets
    Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> Bool -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ [Fd] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Fd]
nonBlockFds Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
listenFDNames'

    [(Fd, String)] -> MaybeT IO [(Fd, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Fd, String)] -> MaybeT IO [(Fd, String)])
-> [(Fd, String)] -> MaybeT IO [(Fd, String)]
forall a b. (a -> b) -> a -> b
$ [Fd] -> [String] -> [(Fd, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Fd]
nonBlockFds [String]
listenFDNames'