Enrich error

Network/Socket.hs

@@ -197,6 +197,8 @@ module Network.Socket (
     socketToFd,
     fdSocket,
     mkSocket,
+    labelSocket,
+    socketLabel,
     socketToHandle,
 
     -- ** Types of Socket

Network/Socket/ByteString.hs

@@ -42,6 +42,7 @@ import Data.ByteString (ByteString)
 
 import Network.Socket.ByteString.IO hiding (recvFrom, sendAllTo, sendTo)
 import qualified Network.Socket.ByteString.IO as G
+import Network.Socket.SockAddr (annotateWithSocket)
 import Network.Socket.Types
 
 -- ----------------------------------------------------------------------------
@@ -72,7 +73,7 @@ import Network.Socket.Types
 -- Returns the number of bytes sent. Applications are responsible for
 -- ensuring that all data has been sent.
 sendTo :: Socket -> ByteString -> SockAddr -> IO Int
-sendTo = G.sendTo
+sendTo s bs sa = G.sendTo s bs sa `annotateWithSocket` (s, Just sa)
 
 -- | Send data to the socket. The recipient can be specified
 -- explicitly, so the socket need not be in a connected state.  Unlike
@@ -81,11 +82,11 @@ sendTo = G.sendTo
 -- raised, and there is no way to determine how much data, if any, was
 -- successfully sent.
 sendAllTo :: Socket -> ByteString -> SockAddr -> IO ()
-sendAllTo = G.sendAllTo
+sendAllTo s bs sa = G.sendAllTo s bs sa `annotateWithSocket` (s, Just sa)
 
 -- | Receive data from the socket.  The socket need not be in a
 -- connected state.  Returns @(bytes, address)@ where @bytes@ is a
 -- 'ByteString' representing the data received and @address@ is a
 -- 'SockAddr' representing the address of the sending socket.
 recvFrom :: Socket -> Int -> IO (ByteString, SockAddr)
-recvFrom = G.recvFrom
+recvFrom s len = G.recvFrom s len `annotateWithSocket` (s, Nothing)

Network/Socket/ByteString/IO.hsc

@@ -57,6 +57,7 @@ import Network.Socket.Internal
 import System.Posix.Types (Fd(..))
 
 import Network.Socket.Flag
+import Network.Socket.SockAddr (annotateWithSocket)
 
 #if !defined(mingw32_HOST_OS)
 import Network.Socket.Posix.Cmsg
@@ -78,8 +79,10 @@ import Network.Socket.Win32.MsgHdr (MsgHdr(..))
 send :: Socket     -- ^ Connected socket
      -> ByteString  -- ^ Data to send
      -> IO Int      -- ^ Number of bytes sent
-send s xs = unsafeUseAsCStringLen xs $ \(str, len) ->
-    sendBuf s (castPtr str) len
+send s xs = send' `annotateWithSocket` (s, Nothing)
+  where
+    send' = unsafeUseAsCStringLen xs $ \(str, len) ->
+      sendBuf s (castPtr str) len
 
 waitWhen0 :: Int -> Socket -> IO ()
 waitWhen0 0 s = when rtsSupportsBoundThreads $
@@ -145,11 +148,12 @@ sendMany :: Socket       -- ^ Connected socket
          -> [ByteString]  -- ^ Data to send
          -> IO ()
 sendMany _ [] = return ()
-sendMany s cs = do
-    sent <- sendManyInner
-    waitWhen0 sent s
-    when (sent >= 0) $ sendMany s $ remainingChunks sent cs
+sendMany s cs = sendMany' `annotateWithSocket` (s, Nothing)
   where
+    sendMany' = do
+        sent <- sendManyInner
+        waitWhen0 sent s
+        when (sent >= 0) $ sendMany s $ remainingChunks sent cs
     sendManyInner =
 #if !defined(mingw32_HOST_OS)
       fmap fromIntegral . withIOVecfromBS cs $ \(iovsPtr, iovsLen) ->
@@ -178,11 +182,12 @@ sendManyTo :: Socket       -- ^ Socket
            -> SockAddr      -- ^ Recipient address
            -> IO ()
 sendManyTo _ [] _    = return ()
-sendManyTo s cs addr = do
-    sent <- fromIntegral <$> sendManyToInner
-    waitWhen0 sent s
-    when (sent >= 0) $ sendManyTo s (remainingChunks sent cs) addr
+sendManyTo s cs addr = sendManyTo' `annotateWithSocket` (s, Nothing)
   where
+    sendManyTo' =  do
+        sent <- fromIntegral <$> sendManyToInner
+        waitWhen0 sent s
+        when (sent >= 0) $ sendManyTo s (remainingChunks sent cs) addr
     sendManyToInner =
       withSockAddr addr $ \addrPtr addrSize ->
 #if !defined(mingw32_HOST_OS)
@@ -225,11 +230,11 @@ sendManyWithFds :: Socket       -- ^ Socket
                 -> [ByteString] -- ^ Data to send
                 -> [Fd]         -- ^ File descriptors
                 -> IO ()
-sendManyWithFds s bss fds =
-    void $
+sendManyWithFds s bss fds = sendManyWithFds' `annotateWithSocket` (s, Nothing)
+  where
+    sendManyWithFds' = void $
         withBufSizs bss $ \bufsizs ->
             sendBufMsg s addr bufsizs cmsgs flags
-  where
     addr = NullSockAddr
     cmsgs = encodeCmsg . (:[]) <$> fds
     flags = mempty
@@ -257,8 +262,8 @@ recv :: Socket        -- ^ Connected socket
      -> Int            -- ^ Maximum number of bytes to receive
      -> IO ByteString  -- ^ Data received
 recv s nbytes
-    | nbytes < 0 = ioError (mkInvalidRecvArgError "Network.Socket.ByteString.recv")
-    | otherwise  = createAndTrim nbytes $ \ptr -> recvBuf s ptr nbytes
+    | nbytes < 0 = ioError (mkInvalidRecvArgError "Network.Socket.ByteString.recv") `annotateWithSocket` (s, Nothing)
+    | otherwise  = createAndTrim nbytes $ \ptr -> recvBuf s ptr nbytes `annotateWithSocket` (s, Nothing)
 
 -- | Receive data from the socket.  The socket need not be in a
 -- connected state.  Returns @(bytes, address)@ where @bytes@ is a
@@ -323,8 +328,10 @@ sendMsg :: Socket       -- ^ Socket
         -> MsgFlag      -- ^ Message flags
         -> IO Int       -- ^ The length actually sent
 sendMsg _ _    []  _ _ = return 0
-sendMsg s addr bss cmsgs flags = withBufSizs bss $ \bufsizs ->
-    sendBufMsg s addr bufsizs cmsgs flags
+sendMsg s addr bss cmsgs flags = sendMsg' `annotateWithSocket` (s, Just addr)
+  where
+    sendMsg' = withBufSizs bss $ \bufsizs ->
+      sendBufMsg s addr bufsizs cmsgs flags
 
 -- | Receive data from the socket using recvmsg(2).
 recvMsg :: Socket  -- ^ Socket
@@ -336,10 +343,12 @@ recvMsg :: Socket  -- ^ Socket
                    --   'MSG_CTRUNC' is returned
         -> MsgFlag -- ^ Message flags
         -> IO (SockAddr, ByteString, [Cmsg], MsgFlag) -- ^ Source address, received data, control messages and message flags
-recvMsg s siz clen flags = do
-    bs@(PS fptr _ _) <- create siz $ \ptr -> zeroMemory ptr (fromIntegral siz)
-    withForeignPtr fptr $ \ptr -> do
-        (addr,len,cmsgs,flags') <- recvBufMsg s [(ptr,siz)] clen flags
-        let bs' | len < siz = PS fptr 0 len
-                | otherwise = bs
-        return (addr, bs', cmsgs, flags')
+recvMsg s siz clen flags = recvMsg' `annotateWithSocket` (s, Nothing)
+  where
+    recvMsg' = do
+        bs@(PS fptr _ _) <- create siz $ \ptr -> zeroMemory ptr (fromIntegral siz)
+        withForeignPtr fptr $ \ptr -> do
+            (addr,len,cmsgs,flags') <- recvBufMsg s [(ptr,siz)] clen flags
+            let bs' | len < siz = PS fptr 0 len
+                    | otherwise = bs
+            return (addr, bs', cmsgs, flags')

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 (C.Errno n) errnoNames of
+  Nothing -> show n
+  Just name -> name
+
+errnoNames :: [(C.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/Shutdown.hs

@@ -22,7 +22,7 @@
 import Network.Socket.Buffer
 import Network.Socket.Imports
 import Network.Socket.Internal
 import Network.Socket.STM
 import Network.Socket.Types
 
 data ShutdownCmd = ShutdownReceive
@@ -40,9 +40,12 @@
 -- 'ShutdownSend', further sends are disallowed.  If it is
 -- 'ShutdownBoth', further sends and receives are disallowed.
 shutdown :: Socket -> ShutdownCmd -> IO ()
-shutdown s stype = void $ withFdSocket s $ \fd ->
-  throwSocketErrorIfMinus1Retry_ "Network.Socket.shutdown" $
-    c_shutdown fd $ sdownCmdToInt stype
+shutdown s stype = shutdown' `annotateIOException` show s
+  where
+    shutdown' =
+      void $ withFdSocket s $ \fd ->
+        throwSocketErrorIfMinus1Retry_ "Network.Socket.shutdown" $
+          c_shutdown fd $ sdownCmdToInt stype
 
 foreign import CALLCONV unsafe "shutdown"
   c_shutdown :: CInt -> CInt -> IO CInt
@@ -54,7 +57,7 @@
 --
 --   Since: 3.1.1.0
 gracefulClose :: Socket -> Int -> IO ()
-gracefulClose s tmout0 = sendRecvFIN `E.finally` close s
+gracefulClose s tmout0 = (sendRecvFIN `E.finally` close s) `annotateIOException` show s
   where
     sendRecvFIN = do
         -- Sending TCP FIN.

Network/Socket/SockAddr.hs

@@ -10,6 +10,7 @@ module Network.Socket.SockAddr (
     recvBufFrom,
     sendBufMsg,
     recvBufMsg,
+    annotateWithSocket,
 ) where
 
 import Control.Exception (IOException, throwIO, try)
@@ -19,6 +20,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 +32,32 @@ import Network.Socket.Types
 
 -- | Getting peer's 'SockAddr'.
 getPeerName :: Socket -> IO SockAddr
-getPeerName = G.getPeerName
+-- annotateWithSocket calls getPeerName.
+-- So, use annotateIOException directly instead of annotateWithSocket.
+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 = connect' `annotateWithSocket` (s, Just sa)
+  where
+    connect' = do
+        G.connect s sa
+        labelSocket s (\label -> label ++ " " ++ 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 `annotateWithSocket` (s, Just 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
@@ -64,7 +75,9 @@ bind s sa = case sa of
                         -- socket not actually in use, remove it and retry bind
                         void (try $ removeFile p :: IO (Either IOError ()))
                         G.bind s sa
-    _ -> G.bind s sa
+    _ -> do
+        G.bind s sa
+        labelSocket s (\label -> label ++ " " ++ show sa)
 
 -- | Accept a connection.  The socket must be bound to an address and
 -- listening for connections.  The return value is a pair @(conn,
@@ -73,14 +86,20 @@ 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 = accept' `annotateWithSocket` (s, Nothing)
+  where
+    accept' = do
+        r@(news, sa) <- G.accept s
+        label <- socketLabel s
+        labelSocket news (\_ -> label ++ " " ++ show sa)
+        return r
 
 -- | 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 `annotateWithSocket` (s, Just 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 +114,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 `annotateWithSocket` (s, Nothing)
 
 -- | Send data to the socket using sendmsg(2).
 sendBufMsg
@@ -111,7 +130,8 @@ 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 `annotateWithSocket` (s, Just sa)
 
 -- | Receive data from the socket using recvmsg(2).
 recvBufMsg
@@ -129,4 +149,14 @@ 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 `annotateWithSocket` (s, Nothing)
+
+------------------------------------------------------------------------
+
+annotateWithSocket :: IO a -> (Socket, Maybe SockAddr) -> IO a
+annotateWithSocket io (s, mpeersa) = do
+    label <- socketLabel s
+    let label' = case mpeersa of
+            Nothing -> "<" ++ label ++ ">"
+            Just peersa -> "<" ++ label ++ "> " ++ show peersa
+    annotateIOException io label'