refactor(Spacecookie.Systemd): move {to,from}Fd to top-level

Move file descriptor conversion into top level bindings, throw
IOExceptions on errors and document them.

SystemdException no longer contains the invalid file descriptor
exception.

1 files changed, 37 insertions, 21 deletions

diff --git a/server/Network/Spacecookie/Systemd.hs b/server/Network/Spacecookie/Systemd.hs
index d43690e..22ab0aa 100644
--- a/server/Network/Spacecookie/Systemd.hs
+++ b/server/Network/Spacecookie/Systemd.hs
@@ -10,11 +10,12 @@ module Network.Spacecookie.Systemd
 
 import Control.Concurrent.MVar (newMVar, takeMVar, mkWeakMVar)
 import Control.Exception.Base
-import Control.Monad (when, void)
+import Control.Monad (when)
 import Data.Maybe (fromMaybe)
 import Foreign.C.Types (CInt (..))
 import GHC.Conc (closeFdWith)
 import Network.Gopher
+import System.IO.Error (mkIOError, userErrorType)
 import System.Posix.Types (Fd (..))
 import System.Socket hiding (Error (..))
 import System.Socket.Family.Inet6
@@ -27,14 +28,42 @@ import System.Systemd.Daemon.Fd (storeFd, getActivatedSockets)
 foreign import ccall unsafe "close"
   c_close :: CInt -> IO CInt
 
--- TODO Check Socket type, ...
-data SystemdException = IncorrectNum | InvalidFd
+-- | Close a 'Fd' using close(1). Throws an 'IOException' on error.
+closeFd :: Fd -> IO ()
+closeFd fd = do
+  res <- c_close $ fromIntegral fd
+  when (res /= 0) $ throwIO
+    $ mkIOError userErrorType "Could not close File Descriptor" Nothing Nothing
+
+-- | Irreversibly convert a 'Socket' into an 'Fd'.
+toFd :: Socket a b c -> IO Fd
+toFd (Socket mvar) = fmap (Fd . fromIntegral) (takeMVar mvar)
+
+-- | Create an 'Socket' from an 'Fd'. This action is unsafe
+--   since the type of the socket is not checked meaning that
+--   whatever type the resulting 'Socket' has is not guaranteed
+--   to be the same as its type indicates. Thus, this function
+--   needs to be used with care so the safety guarantees of
+--   'Socket' are not violated.
+--
+--   Throws an 'IOException' if the 'Fd' is invalid.
+fromFd :: Fd -> IO (Socket a b c)
+fromFd fd = do
+  -- TODO Validate socket type
+  when (fd < 0) $ throwIO
+    $ mkIOError userErrorType "Invalid File Descriptor" Nothing Nothing
+  mfd <- newMVar (fromIntegral fd)
+  let s = Socket mfd
+  _ <- mkWeakMVar mfd (close s)
+  pure s
+
+data SystemdException
+  = IncorrectNum
   deriving (Eq, Ord)
 
+instance Exception SystemdException
 instance Show SystemdException where
   show IncorrectNum = "SystemdException: Only exactly one Socket is supported"
-  show InvalidFd    = "SystemdException: Invalid File Descriptor received"
-instance Exception SystemdException
 
 systemdSocket :: GopherConfig -> IO (Socket Inet6 Stream TCP)
 systemdSocket cfg = getActivatedSockets >>= \sockets ->
@@ -42,20 +71,9 @@ systemdSocket cfg = getActivatedSockets >>= \sockets ->
     Nothing -> setupGopherSocket cfg
     Just [fd] -> do
       listenWarning
-      toSocket fd
+      fromFd fd
     Just _ -> throwIO IncorrectNum
-  where toSocket :: Fd -> IO (Socket Inet6 Stream TCP)
-        toSocket fd = do
-          when (fd < 0) $ throwIO InvalidFd
-          mfd <- newMVar (fromIntegral fd)
-          let s = Socket mfd
-          _ <- mkWeakMVar mfd (close s)
-          pure s
-        -- logs a warning that a listen addr which
-        -- may differ from the listen addr of the
-        -- systemd socket is specified if it is
-        -- necessary and possible
-        listenWarning = fromMaybe (pure ()) $ do
+  where listenWarning = fromMaybe (pure ()) $ do
           logAction <- cLogHandler cfg
           addr <- cListenAddr cfg
           pure . logAction GopherLogLevelWarn
@@ -70,6 +88,4 @@ systemdStoreOrClose s = do
   res <- storeFd fd
   case res of
     Just () -> return ()
-    Nothing -> closeFdWith (void . c_close . fromIntegral) fd
-  where toFd :: Socket Inet6 Stream TCP -> IO Fd
-        toFd (Socket mvar) = fmap (Fd . fromIntegral) (takeMVar mvar)
+    Nothing -> closeFdWith closeFd fd