implementing annotateIOException

Author: kazu-yamamoto

Network/Socket/Internal.hs

@@ -37,6 +37,7 @@ module Network.Socket.Internal
 #if defined(mingw32_HOST_OS)
     , throwSocketErrorIfMinus1ButRetry
 #endif
+    , annotateIOException
     -- ** Guards that wait and retry if the operation would block
     -- | These guards are based on 'throwSocketErrorIfMinus1RetryMayBlock'.
     -- They wait for socket readiness if the action fails with @EWOULDBLOCK@
@@ -78,6 +79,65 @@ import Network.Socket.Cbits
 import Network.Socket.Imports
 import Network.Socket.Types
 
+import qualified Foreign.C.Error as C
+import GHC.IO.Exception (IOException (..))
+import System.IO.Error (modifyIOError)
+
+annotateIOException :: IO a -> String -> IO a
+annotateIOException io anno = modifyIOError f io
+  where
+    f ioe = ioe { ioe_description = ioe_description ioe ++ " " ++ errname ++ anno }
+      where
+         errname = case ioe_errno ioe of
+           Nothing -> ""
+           Just n -> "[" ++ showErrno n ++ "] "
+
+showErrno :: CInt -> String
+showErrno n = case lookup (Errno n) errnoNames of
+  Nothing -> show n
+  Just name -> name
+
+errnoNames :: [(Errno, String)]
+errnoNames = [
+    (C.eACCES,          "EACCES")
+  , (C.eADDRINUSE,      "EADDRINUSE")
+  , (C.eADDRNOTAVAIL,   "EADDRNOTAVAIL")
+  , (C.eAFNOSUPPORT,    "EAFNOSUPPORT")
+  , (C.eAGAIN,          "EAGAIN")
+  , (C.eBADF,           "EBADF")
+  , (C.eCONNABORTED,    "ECONNABORTED")
+  , (C.eCONNRESET,      "ECONNRESET")
+  , (C.eDESTADDRREQ,    "EDESTADDRREQ")
+  , (C.eEXIST,          "EEXIST")
+  , (C.eFAULT,          "EFAULT")
+  , (C.eINTR,           "EINTR")
+  , (C.eINVAL,          "EINVAL")
+  , (C.eIO,             "EIO")
+  , (C.eISCONN,         "EISCONN")
+  , (C.eISDIR,          "EISDIR")
+  , (C.eLOOP,           "ELOOP")
+  , (C.eMFILE,          "EMFILE")
+  , (C.eMSGSIZE,        "EMSGSIZE")
+  , (C.eNAMETOOLONG,    "ENAMETOOLONG")
+  , (C.eNETDOWN,        "ENETDOWN")
+  , (C.eNETUNREACH,     "ENETUNREACH")
+  , (C.eMFILE,          "EMFILE")
+  , (C.eNFILE,          "ENFILE")
+  , (C.eNOBUFS,         "ENOBUFS")
+  , (C.eNOENT,          "ENOENT")
+  , (C.eNOMEM,          "ENOMEM")
+  , (C.eNOTCONN,        "ENOTCONN")
+  , (C.eNOTDIR,         "ENOTDIR")
+  , (C.eNOTSOCK,        "ENOTSOCK")
+  , (C.eOPNOTSUPP,      "EOPNOTSUPP")
+  , (C.ePIPE,           "EPIPE")
+  , (C.ePROTONOSUPPORT, "EPROTONOSUPPORT")
+  , (C.ePROTOTYPE,      "EPROTOTYPE")
+  , (C.eROFS,           "EROFS")
+  , (C.eTIMEDOUT,       "ETIMEDOUT")
+  , (C.eWOULDBLOCK,     "EWOULDBLOCK")
+  ]
+
 -- ---------------------------------------------------------------------
 -- Guards for socket operations that may fail
 

Network/Socket/SockAddr.hs

@@ -19,6 +19,7 @@ import System.IO.Error (isAlreadyInUseError, isDoesNotExistError)
 import qualified Network.Socket.Buffer as G
 import Network.Socket.Flag
 import Network.Socket.Imports
+import Network.Socket.Internal
 import qualified Network.Socket.Name as G
 import qualified Network.Socket.Syscall as G
 #if !defined(mingw32_HOST_OS)
@@ -30,23 +31,26 @@ import Network.Socket.Types
 
 -- | Getting peer's 'SockAddr'.
 getPeerName :: Socket -> IO SockAddr
-getPeerName = G.getPeerName
+getPeerName s = G.getPeerName s `annotateIOException` show s
 
 -- | Getting my 'SockAddr'.
 getSocketName :: Socket -> IO SockAddr
-getSocketName = G.getSocketName
+getSocketName s = G.getSocketName s `annotateIOException` show s
 
 -- | Connect to a remote socket at address.
 connect :: Socket -> SockAddr -> IO ()
-connect = G.connect
+connect s sa = G.connect s sa `annotateIOException` (show s ++ " " ++ show sa)
 
 -- | Bind the socket to an address. The socket must not already be
 -- bound.  The 'Family' passed to @bind@ must be the
 -- same as that passed to 'socket'.  If the special port number
 -- 'defaultPort' is passed then the system assigns the next available
 -- use port.
 bind :: Socket -> SockAddr -> IO ()
-bind s sa = case sa of
+bind s sa = bind' s sa `annotateIOException` (show s ++ " " ++ show sa)
+
+bind' :: Socket -> SockAddr -> IO ()
+bind' s sa = case sa of
     SockAddrUnix p -> do
         -- gracefully handle the fact that UNIX systems don't clean up closed UNIX
         -- domain sockets, inspired by https://stackoverflow.com/a/13719866
@@ -73,14 +77,14 @@ bind s sa = case sa of
 -- to the socket on the other end of the connection.
 -- On Unix, FD_CLOEXEC is set to the new 'Socket'.
 accept :: Socket -> IO (Socket, SockAddr)
-accept = G.accept
+accept s = G.accept s `annotateIOException` show s
 
 -- | Send data to the socket.  The recipient can be specified
 -- explicitly, so the socket need not be in a connected state.
 -- Returns the number of bytes sent.  Applications are responsible for
 -- ensuring that all data has been sent.
 sendBufTo :: Socket -> Ptr a -> Int -> SockAddr -> IO Int
-sendBufTo = G.sendBufTo
+sendBufTo s ptr len sa = G.sendBufTo s ptr len sa `annotateIOException` (show s ++ " " ++ show sa)
 
 -- | Receive data from the socket, writing it into buffer instead of
 -- creating a new string.  The socket need not be in a connected
@@ -95,7 +99,7 @@ sendBufTo = G.sendBufTo
 -- NOTE: blocking on Windows unless you compile with -threaded (see
 -- GHC ticket #1129)
 recvBufFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr)
-recvBufFrom = G.recvBufFrom
+recvBufFrom s ptr len = G.recvBufFrom s ptr len `annotateIOException` show s
 
 -- | Send data to the socket using sendmsg(2).
 sendBufMsg
@@ -111,7 +115,9 @@ sendBufMsg
     -- ^ Message flags
     -> IO Int
     -- ^ The length actually sent
-sendBufMsg = G.sendBufMsg
+sendBufMsg s sa dats cmgs flag =
+    G.sendBufMsg s sa dats cmgs flag
+        `annotateIOException` (show s ++ " " ++ show sa)
 
 -- | Receive data from the socket using recvmsg(2).
 recvBufMsg
@@ -129,4 +135,4 @@ recvBufMsg
     -- ^ Message flags
     -> IO (SockAddr, Int, [Cmsg], MsgFlag)
     -- ^ Source address, received data, control messages and message flags
-recvBufMsg = G.recvBufMsg
+recvBufMsg s bufs len flag = G.recvBufMsg s bufs len flag `annotateIOException` show s

Network/Socket/Syscall.hs

@@ -75,22 +75,23 @@ socket :: Family         -- Family Name (usually AF_INET)
        -> SocketType     -- Socket Type (usually Stream)
        -> ProtocolNumber -- Protocol Number (getProtocolByName to find value)
        -> IO Socket      -- Unconnected Socket
-socket family stype protocol = E.bracketOnError create c_close $ \fd -> do
-    -- Let's ensure that the socket (file descriptor) is closed even on
-    -- asynchronous exceptions.
-    setNonBlock fd
-    s <- mkSocket fd
-    -- This socket is not managed by the IO manager yet.
-    -- So, we don't have to call "close" which uses "closeFdWith".
-    unsetIPv6Only s
-    setDontFragment s
-    return s
+socket family stype protocol =
+    E.bracketOnError create c_close setProp `annotateIOException` (show stype ++ " " ++ show protocol)
   where
+    setProp fd = do
+        -- Let's ensure that the socket (file descriptor) is closed even on
+        -- asynchronous exceptions.
+        setNonBlock fd
+        s <- mkSocket fd
+        -- This socket is not managed by the IO manager yet.
+        -- So, we don't have to call "close" which uses "closeFdWith".
+        unsetIPv6Only s
+        setDontFragment s
+        return s
     create = do
         let c_stype = modifyFlag $ packSocketType stype
         throwSocketErrorIfMinus1Retry "Network.Socket.socket" $
             c_socket (packFamily family) c_stype protocol
-
 #ifdef HAVE_ADVANCED_SOCKET_FLAGS
     modifyFlag c_stype = c_stype .|. sockNonBlock
 #else
@@ -141,7 +142,7 @@ socket family stype protocol = E.bracketOnError create c_close $ \fd -> do
 bind :: SocketAddress sa => Socket -> sa -> IO ()
 bind s sa = withSocketAddress sa $ \p_sa siz -> void $ withFdSocket s $ \fd -> do
   let sz = fromIntegral siz
-  throwSocketErrorIfMinus1Retry "Network.Socket.bind" $ c_bind fd p_sa sz
+  throwSocketErrorIfMinus1Retry "Network.Socket.bind" (c_bind fd p_sa sz)
 
 -----------------------------------------------------------------------------
 -- Connecting a socket
@@ -181,9 +182,11 @@ connectLoop s p_sa sz = withFdSocket s $ \fd -> loop fd
 -- specifies the maximum number of queued connections and should be at
 -- least 1; the maximum value is system-dependent (usually 5).
 listen :: Socket -> Int -> IO ()
-listen s backlog = withFdSocket s $ \fd -> do
-    throwSocketErrorIfMinus1Retry_ "Network.Socket.listen" $
-        c_listen fd $ fromIntegral backlog
+listen s backlog = withFdSocket s listen' `annotateIOException` show s
+  where
+    listen' fd =
+        throwSocketErrorIfMinus1Retry_ "Network.Socket.listen" $
+            c_listen fd $ fromIntegral backlog
 
 -----------------------------------------------------------------------------
 -- Accept