0 | module System.Systemd.Internal
  1 |
  2 | import Control.Monad.Elin
  3 | import Data.String
  4 | import System
  5 | import System.FFI
  6 | import System.Posix.Errno
  7 | import System.Posix.File
  8 | import System.Posix.Socket
  9 |
 10 | --------------------------------------------------------------------------------
 11 | --          Raw Primitives
 12 | --------------------------------------------------------------------------------
 13 |
 14 | export %foreign "C:sd_notify_with_fd,systemd-idris"
 15 | prim__sdNotifyWithFd : Int -> String -> Bits64 -> AnyPtr -> Bits32 -> Int -> PrimIO Int
 16 |
 17 | --------------------------------------------------------------------------------
 18 | --          Internal utilities
 19 | --------------------------------------------------------------------------------
 20 |
 21 | private
 22 | envvariablename : String
 23 | envvariablename =
 24 |   "NOTIFY_SOCKET"
 25 |
 26 | ||| Unset all enviornment variables related to Systemd.
 27 | ||| Calls to functions like `System.Systemd.Daemon.notify` and
 28 | ||| `System.Systemd.Daemon.getActivatedSockets` will return
 29 | ||| Nothing after that.
 30 | private
 31 | unsetEnvironment : IO ()
 32 | unsetEnvironment =
 33 |   traverse_ unsetEnv
 34 |             [ envvariablename
 35 |             , "LISTEN_PID"
 36 |             , "LISTEN_FDS"
 37 |             , "LISTEN_FDNAMES"
 38 |             ]
 39 |
 40 | private
 41 | sendBufWithFdTo :  Socket AF_UNIX
 42 |                 -> String
 43 |                 -> SockaddrUn
 44 |                 -> Fd
 45 |                 -> IO Int
 46 | sendBufWithFdTo socket state socketaddress filedesc =
 47 |   primIO $
 48 |     prim__sdNotifyWithFd (cast {to=Int} $ fd $ cast {to=Fd} socket)
 49 |                          state
 50 |                          (cast {to=Bits64} (strLength state))
 51 |                          (ptr AF_UNIX socketaddress)
 52 |                          (addrSize AF_UNIX)
 53 |                          (cast {to=Int} (fd filedesc))
 54 |
 55 | export
 56 | notifyWithFd_ :  Bool
 57 |               -> String
 58 |               -> Maybe Fd
 59 |               -> IO (Maybe ())
 60 | notifyWithFd_ unset_env state fd =
 61 |   case !(runElinIO $ notifyImpl state fd) of
 62 |     Left  err  => do
 63 |       when unset_env unsetEnvironment
 64 |       stdoutLn $
 65 |         show err
 66 |       pure Nothing
 67 |     Right res' => do
 68 |       when unset_env unsetEnvironment
 69 |       pure $
 70 |         Just res'
 71 |   where
 72 |     isValidPath :  String
 73 |                 -> Bool
 74 |     isValidPath path =
 75 |       (length path >= 2) &&
 76 |       (isPrefixOf "@" path || isPrefixOf "/" path)
 77 |     notifyImpl :  String
 78 |                -> Maybe Fd
 79 |                -> Elin World [Errno] ()
 80 |     notifyImpl state fd = do
 81 |       True <- pure $ state /= ""
 82 |         | False =>
 83 |             pure ()
 84 |       Just socketpath <- liftIO $ getEnv envvariablename
 85 |         | Nothing =>
 86 |             pure ()
 87 |       True <- pure $ isValidPath socketpath
 88 |         | False =>
 89 |             pure () 
 90 |       let socketpath' =  case fastUnpack socketpath of
 91 |                            Nil       =>
 92 |                              ""
 93 |                            (x :: xs) =>
 94 |                              case x == '@' of
 95 |                                True  =>
 96 |                                  fastPack $
 97 |                                    '\0' :: xs
 98 |                                False =>
 99 |                                  fastPack $
100 |                                    (x :: xs)
101 |       socketfd        <- socket AF_UNIX
102 |                                 SOCK_DGRAM
103 |       srv             <- runIO ( sockaddrUn socketpath
104 |                                )
105 |       Just socket' <- pure fd
106 |         | Nothing =>
107 |             ignore $
108 |               sendto socketfd
109 |                      state
110 |                      0
111 |                      srv
112 |       liftIO $
113 |         ignore $
114 |           sendBufWithFdTo socketfd
115 |                           state
116 |                           srv
117 |                           socket'
118 |