0 | module System.Systemd.Daemon.Fd
  1 |
  2 | import public System.Systemd.Internal
  3 |
  4 | import Control.Monad.Elin
  5 | import Data.List1
  6 | import Data.String
  7 | import Data.Zippable
  8 | import System
  9 | import System.Posix.Errno
 10 | import System.Posix.File
 11 | import System.Posix.Process
 12 | import System.Posix.Socket
 13 |
 14 | private
 15 | fdstart : Int
 16 | fdstart = 3
 17 |
 18 | ||| Same as `System.Systemd.Daemon.notify`, but send along an `Fd`.
 19 | ||| Note that the caller must set the message, i. e. send @FDSTORE=1@
 20 | ||| to actually store the file descriptor. In most cases it is probably best
 21 | ||| to use 'storeFd' or the notify-functions from `System.Systemd.Daemon`.
 22 | ||| Equivalent to standard `System.Systemd.Daemon.notifyWithFD`.
 23 | export
 24 | notifyWithFd :  Bool
 25 |              -> String
 26 |              -> Fd
 27 |              -> IO (Maybe ())
 28 | notifyWithFd unset_env state sock =
 29 |   notifyWithFd_ unset_env
 30 |                 state
 31 |                 (Just sock)
 32 |
 33 | ||| Notify Systemd to store a file descriptor for us. This together
 34 | ||| with `getActivatedSockets` allows for zero downtime
 35 | ||| restarts and socket activation.
 36 | ||| Equivalent to standard `System.Systemd.Daemon.storeFd`.
 37 | export
 38 | storeFd :  Fd
 39 |         -> IO (Maybe ())
 40 | storeFd sock =
 41 |   notifyWithFd False
 42 |                "FDSTORE=1"
 43 |                sock
 44 |
 45 | ||| Like `storeFd`, but associate the file descriptor with a name.
 46 | ||| Best used along with `getActivatedSocketsWithNames`.
 47 | ||| Equivalent to standard `System.Systemd.Daemon.storeFdWithName`.
 48 | export
 49 | storeFdWithName :  Fd
 50 |                 -> String
 51 |                 -> IO (Maybe ())
 52 | storeFdWithName fd name =
 53 |   notifyWithFd False
 54 |                ("FDSTORE=1\nFDNAME=" ++ name)
 55 |                fd
 56 |
 57 | ||| Return Just a list of file descriptors if the current process
 58 | ||| has been activated with one or more socket by systemd, Nothing
 59 | ||| otherwise.
 60 | ||| The file descriptors are in the same order as the sockets in the
 61 | ||| associated .socket file.
 62 | ||| The sockets will have their family, type,
 63 | ||| and status set according to the .socket file.
 64 | ||| Equivalent to standard `System.Systemd.Daemon.getActivatedSockets`.
 65 | export
 66 | getActivatedSockets : IO (Maybe (List Fd))
 67 | getActivatedSockets = do
 68 |   Right res <- runElinIO getActivatedSockets'
 69 |     | Left err => do
 70 |         () <- stdoutLn $
 71 |           show err
 72 |         pure Nothing
 73 |   pure res
 74 |   where
 75 |     getActivatedSockets' : Elin World [Errno] (Maybe (List Fd))
 76 |     getActivatedSockets' = do
 77 |       Just listenpid <- liftIO $ getEnv "LISTEN_PID"
 78 |         | Nothing =>
 79 |             pure Nothing
 80 |       Just listenfds <- liftIO $ getEnv "LISTEN_FDS"
 81 |         | Nothing =>
 82 |             pure Nothing
 83 |       mypid <- getpid
 84 |       True <- pure $ (cast {to=Int32} listenpid) == mypid
 85 |         | False =>
 86 |             pure Nothing
 87 |       let fds  = map (cast {to=Bits32})
 88 |                      [fdstart .. (fdstart + ((cast {to=Int} listenfds) - 1))]
 89 |           fds' = map MkFd fds
 90 |       for_ fds' $ \fd =>
 91 |         addFlags fd O_NONBLOCK
 92 |       pure $
 93 |         Just fds'
 94 |
 95 | ||| Like 'getActivatedSockets', but also return the associated names.
 96 | ||| If a file descriptor has no associated name, it will be a generic
 97 | ||| one set by systemd.
 98 | ||| Equivalent to standard `System.Systemd.Daemon.getActivatedSocketsWithNames`.
 99 | export
100 | getActivatedSocketsWithNames : IO (Maybe (List (Fd, String)))
101 | getActivatedSocketsWithNames = do
102 |   Right res <- runElinIO getActivatedSocketsWithNames'
103 |     | Left err => do
104 |         () <- stdoutLn $
105 |           show err
106 |         pure Nothing
107 |   pure res
108 |   where
109 |     getActivatedSocketsWithNames' : Elin World [Errno] (Maybe (List (Fd, String)))
110 |     getActivatedSocketsWithNames' = do
111 |       Just listenfdnames <- liftIO $ getEnv "LISTEN_FDNAMES"
112 |         | Nothing =>
113 |             pure Nothing
114 |       let listenfdnames' = forget $
115 |                              split (== ':') listenfdnames
116 |       Just nonblockfds <- liftIO getActivatedSockets
117 |         | Nothing =>
118 |            pure Nothing
119 |       True <- pure $ length nonblockfds == length listenfdnames'
120 |         | False =>
121 |             pure Nothing
122 |       pure $
123 |         Just $
124 |           zip nonblockfds
125 |               listenfdnames'
126 |