Skip to content

Commit 6056bd9

Browse files
kazu-yamamotokazu-yamamoto
committed
Merge PR #610 
2 parents cc88a6c + 7996583 commit 6056bd9

8 files changed

Lines changed: 194 additions & 69 deletions

File tree

‎Network/Socket.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -197,6 +197,8 @@ module Network.Socket (
197197
socketToFd,
198198
fdSocket,
199199
mkSocket,
200+
labelSocket,
201+
socketLabel,
200202
socketToHandle,
201203

202204
-- ** Types of Socket

‎Network/Socket/ByteString.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,7 @@ import Data.ByteString (ByteString)
4242

4343
import Network.Socket.ByteString.IO hiding (recvFrom, sendAllTo, sendTo)
4444
import qualified Network.Socket.ByteString.IO as G
45+
import Network.Socket.SockAddr (annotateWithSocket)
4546
import Network.Socket.Types
4647

4748
-- ----------------------------------------------------------------------------
@@ -72,7 +73,7 @@ import Network.Socket.Types
7273
-- Returns the number of bytes sent. Applications are responsible for
7374
-- ensuring that all data has been sent.
7475
sendTo :: Socket -> ByteString -> SockAddr -> IO Int
75-
sendTo = G.sendTo
76+
sendTo s bs sa = G.sendTo s bs sa `annotateWithSocket` (s, Just sa)
7677

7778
-- | Send data to the socket. The recipient can be specified
7879
-- explicitly, so the socket need not be in a connected state. Unlike
@@ -81,11 +82,11 @@ sendTo = G.sendTo
8182
-- raised, and there is no way to determine how much data, if any, was
8283
-- successfully sent.
8384
sendAllTo :: Socket -> ByteString -> SockAddr -> IO ()
84-
sendAllTo = G.sendAllTo
85+
sendAllTo s bs sa = G.sendAllTo s bs sa `annotateWithSocket` (s, Just sa)
8586

8687
-- | Receive data from the socket. The socket need not be in a
8788
-- connected state. Returns @(bytes, address)@ where @bytes@ is a
8889
-- 'ByteString' representing the data received and @address@ is a
8990
-- 'SockAddr' representing the address of the sending socket.
9091
recvFrom :: Socket -> Int -> IO (ByteString, SockAddr)
91-
recvFrom = G.recvFrom
92+
recvFrom s len = G.recvFrom s len `annotateWithSocket` (s, Nothing)

‎Network/Socket/ByteString/IO.hsc‎

Lines changed: 33 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,7 @@ import Network.Socket.Internal
5757
import System.Posix.Types (Fd(..))
5858

5959
import Network.Socket.Flag
60+
import Network.Socket.SockAddr (annotateWithSocket)
6061

6162
#if !defined(mingw32_HOST_OS)
6263
import Network.Socket.Posix.Cmsg
@@ -78,8 +79,10 @@ import Network.Socket.Win32.MsgHdr (MsgHdr(..))
7879
send :: Socket -- ^ Connected socket
7980
-> ByteString -- ^ Data to send
8081
-> IO Int -- ^ Number of bytes sent
81-
send s xs = unsafeUseAsCStringLen xs $ \(str, len) ->
82-
sendBuf s (castPtr str) len
82+
send s xs = send' `annotateWithSocket` (s, Nothing)
83+
where
84+
send' = unsafeUseAsCStringLen xs $ \(str, len) ->
85+
sendBuf s (castPtr str) len
8386

8487
waitWhen0 :: Int -> Socket -> IO ()
8588
waitWhen0 0 s = when rtsSupportsBoundThreads $
@@ -145,11 +148,12 @@ sendMany :: Socket -- ^ Connected socket
145148
-> [ByteString] -- ^ Data to send
146149
-> IO ()
147150
sendMany _ [] = return ()
148-
sendMany s cs = do
149-
sent <- sendManyInner
150-
waitWhen0 sent s
151-
when (sent >= 0) $ sendMany s $ remainingChunks sent cs
151+
sendMany s cs = sendMany' `annotateWithSocket` (s, Nothing)
152152
where
153+
sendMany' = do
154+
sent <- sendManyInner
155+
waitWhen0 sent s
156+
when (sent >= 0) $ sendMany s $ remainingChunks sent cs
153157
sendManyInner =
154158
#if !defined(mingw32_HOST_OS)
155159
fmap fromIntegral . withIOVecfromBS cs $ \(iovsPtr, iovsLen) ->
@@ -178,11 +182,12 @@ sendManyTo :: Socket -- ^ Socket
178182
-> SockAddr -- ^ Recipient address
179183
-> IO ()
180184
sendManyTo _ [] _ = return ()
181-
sendManyTo s cs addr = do
182-
sent <- fromIntegral <$> sendManyToInner
183-
waitWhen0 sent s
184-
when (sent >= 0) $ sendManyTo s (remainingChunks sent cs) addr
185+
sendManyTo s cs addr = sendManyTo' `annotateWithSocket` (s, Nothing)
185186
where
187+
sendManyTo' = do
188+
sent <- fromIntegral <$> sendManyToInner
189+
waitWhen0 sent s
190+
when (sent >= 0) $ sendManyTo s (remainingChunks sent cs) addr
186191
sendManyToInner =
187192
withSockAddr addr $ \addrPtr addrSize ->
188193
#if !defined(mingw32_HOST_OS)
@@ -225,11 +230,11 @@ sendManyWithFds :: Socket -- ^ Socket
225230
-> [ByteString] -- ^ Data to send
226231
-> [Fd] -- ^ File descriptors
227232
-> IO ()
228-
sendManyWithFds s bss fds =
229-
void $
233+
sendManyWithFds s bss fds = sendManyWithFds' `annotateWithSocket` (s, Nothing)
234+
where
235+
sendManyWithFds' = void $
230236
withBufSizs bss $ \bufsizs ->
231237
sendBufMsg s addr bufsizs cmsgs flags
232-
where
233238
addr = NullSockAddr
234239
cmsgs = encodeCmsg . (:[]) <$> fds
235240
flags = mempty
@@ -257,8 +262,8 @@ recv :: Socket -- ^ Connected socket
257262
-> Int -- ^ Maximum number of bytes to receive
258263
-> IO ByteString -- ^ Data received
259264
recv s nbytes
260-
| nbytes < 0 = ioError (mkInvalidRecvArgError "Network.Socket.ByteString.recv")
261-
| otherwise = createAndTrim nbytes $ \ptr -> recvBuf s ptr nbytes
265+
| nbytes < 0 = ioError (mkInvalidRecvArgError "Network.Socket.ByteString.recv") `annotateWithSocket` (s, Nothing)
266+
| otherwise = createAndTrim nbytes $ \ptr -> recvBuf s ptr nbytes `annotateWithSocket` (s, Nothing)
262267

263268
-- | Receive data from the socket. The socket need not be in a
264269
-- connected state. Returns @(bytes, address)@ where @bytes@ is a
@@ -323,8 +328,10 @@ sendMsg :: Socket -- ^ Socket
323328
-> MsgFlag -- ^ Message flags
324329
-> IO Int -- ^ The length actually sent
325330
sendMsg _ _ [] _ _ = return 0
326-
sendMsg s addr bss cmsgs flags = withBufSizs bss $ \bufsizs ->
327-
sendBufMsg s addr bufsizs cmsgs flags
331+
sendMsg s addr bss cmsgs flags = sendMsg' `annotateWithSocket` (s, Just addr)
332+
where
333+
sendMsg' = withBufSizs bss $ \bufsizs ->
334+
sendBufMsg s addr bufsizs cmsgs flags
328335

329336
-- | Receive data from the socket using recvmsg(2).
330337
recvMsg :: Socket -- ^ Socket
@@ -336,10 +343,12 @@ recvMsg :: Socket -- ^ Socket
336343
-- 'MSG_CTRUNC' is returned
337344
-> MsgFlag -- ^ Message flags
338345
-> IO (SockAddr, ByteString, [Cmsg], MsgFlag) -- ^ Source address, received data, control messages and message flags
339-
recvMsg s siz clen flags = do
340-
bs@(PS fptr _ _) <- create siz $ \ptr -> zeroMemory ptr (fromIntegral siz)
341-
withForeignPtr fptr $ \ptr -> do
342-
(addr,len,cmsgs,flags') <- recvBufMsg s [(ptr,siz)] clen flags
343-
let bs' | len < siz = PS fptr 0 len
344-
| otherwise = bs
345-
return (addr, bs', cmsgs, flags')
346+
recvMsg s siz clen flags = recvMsg' `annotateWithSocket` (s, Nothing)
347+
where
348+
recvMsg' = do
349+
bs@(PS fptr _ _) <- create siz $ \ptr -> zeroMemory ptr (fromIntegral siz)
350+
withForeignPtr fptr $ \ptr -> do
351+
(addr,len,cmsgs,flags') <- recvBufMsg s [(ptr,siz)] clen flags
352+
let bs' | len < siz = PS fptr 0 len
353+
| otherwise = bs
354+
return (addr, bs', cmsgs, flags')

‎Network/Socket/Internal.hs‎

Lines changed: 60 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ module Network.Socket.Internal
3737
#if defined(mingw32_HOST_OS)
3838
, throwSocketErrorIfMinus1ButRetry
3939
#endif
40+
, annotateIOException
4041
-- ** Guards that wait and retry if the operation would block
4142
-- | These guards are based on 'throwSocketErrorIfMinus1RetryMayBlock'.
4243
-- They wait for socket readiness if the action fails with @EWOULDBLOCK@
@@ -78,6 +79,65 @@ import Network.Socket.Cbits
7879
import Network.Socket.Imports
7980
import Network.Socket.Types
8081

82+
import qualified Foreign.C.Error as C
83+
import GHC.IO.Exception (IOException (..))
84+
import System.IO.Error (modifyIOError)
85+
86+
annotateIOException :: IO a -> String -> IO a
87+
annotateIOException io anno = modifyIOError f io
88+
where
89+
f ioe = ioe { ioe_description = ioe_description ioe ++ " " ++ errname ++ anno }
90+
where
91+
errname = case ioe_errno ioe of
92+
Nothing -> ""
93+
Just n -> "[" ++ showErrno n ++ "] "
94+
95+
showErrno :: CInt -> String
96+
showErrno n = case lookup (C.Errno n) errnoNames of
97+
Nothing -> show n
98+
Just name -> name
99+
100+
errnoNames :: [(C.Errno, String)]
101+
errnoNames = [
102+
(C.eACCES, "EACCES")
103+
, (C.eADDRINUSE, "EADDRINUSE")
104+
, (C.eADDRNOTAVAIL, "EADDRNOTAVAIL")
105+
, (C.eAFNOSUPPORT, "EAFNOSUPPORT")
106+
, (C.eAGAIN, "EAGAIN")
107+
, (C.eBADF, "EBADF")
108+
, (C.eCONNABORTED, "ECONNABORTED")
109+
, (C.eCONNRESET, "ECONNRESET")
110+
, (C.eDESTADDRREQ, "EDESTADDRREQ")
111+
, (C.eEXIST, "EEXIST")
112+
, (C.eFAULT, "EFAULT")
113+
, (C.eINTR, "EINTR")
114+
, (C.eINVAL, "EINVAL")
115+
, (C.eIO, "EIO")
116+
, (C.eISCONN, "EISCONN")
117+
, (C.eISDIR, "EISDIR")
118+
, (C.eLOOP, "ELOOP")
119+
, (C.eMFILE, "EMFILE")
120+
, (C.eMSGSIZE, "EMSGSIZE")
121+
, (C.eNAMETOOLONG, "ENAMETOOLONG")
122+
, (C.eNETDOWN, "ENETDOWN")
123+
, (C.eNETUNREACH, "ENETUNREACH")
124+
, (C.eMFILE, "EMFILE")
125+
, (C.eNFILE, "ENFILE")
126+
, (C.eNOBUFS, "ENOBUFS")
127+
, (C.eNOENT, "ENOENT")
128+
, (C.eNOMEM, "ENOMEM")
129+
, (C.eNOTCONN, "ENOTCONN")
130+
, (C.eNOTDIR, "ENOTDIR")
131+
, (C.eNOTSOCK, "ENOTSOCK")
132+
, (C.eOPNOTSUPP, "EOPNOTSUPP")
133+
, (C.ePIPE, "EPIPE")
134+
, (C.ePROTONOSUPPORT, "EPROTONOSUPPORT")
135+
, (C.ePROTOTYPE, "EPROTOTYPE")
136+
, (C.eROFS, "EROFS")
137+
, (C.eTIMEDOUT, "ETIMEDOUT")
138+
, (C.eWOULDBLOCK, "EWOULDBLOCK")
139+
]
140+
81141
-- ---------------------------------------------------------------------
82142
-- Guards for socket operations that may fail
83143

‎Network/Socket/Shutdown.hs‎

Lines changed: 7 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -40,9 +40,12 @@ sdownCmdToInt ShutdownBoth = 2
4040
-- 'ShutdownSend', further sends are disallowed. If it is
4141
-- 'ShutdownBoth', further sends and receives are disallowed.
4242
shutdown :: Socket -> ShutdownCmd -> IO ()
43-
shutdown s stype = void $ withFdSocket s $ \fd ->
44-
throwSocketErrorIfMinus1Retry_ "Network.Socket.shutdown" $
45-
c_shutdown fd $ sdownCmdToInt stype
43+
shutdown s stype = shutdown' `annotateIOException` show s
44+
where
45+
shutdown' =
46+
void $ withFdSocket s $ \fd ->
47+
throwSocketErrorIfMinus1Retry_ "Network.Socket.shutdown" $
48+
c_shutdown fd $ sdownCmdToInt stype
4649

4750
foreign import CALLCONV unsafe "shutdown"
4851
c_shutdown :: CSocket -> CInt -> IO CInt
@@ -54,7 +57,7 @@ foreign import CALLCONV unsafe "shutdown"
5457
--
5558
-- Since: 3.1.1.0
5659
gracefulClose :: Socket -> Int -> IO ()
57-
gracefulClose s tmout0 = sendRecvFIN `E.finally` close s
60+
gracefulClose s tmout0 = (sendRecvFIN `E.finally` close s) `annotateIOException` show s
5861
where
5962
sendRecvFIN = do
6063
-- Sending TCP FIN.

‎Network/Socket/SockAddr.hs‎

Lines changed: 40 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module Network.Socket.SockAddr (
1010
recvBufFrom,
1111
sendBufMsg,
1212
recvBufMsg,
13+
annotateWithSocket,
1314
) where
1415

1516
import Control.Exception (IOException, throwIO, try)
@@ -19,6 +20,7 @@ import System.IO.Error (isAlreadyInUseError, isDoesNotExistError)
1920
import qualified Network.Socket.Buffer as G
2021
import Network.Socket.Flag
2122
import Network.Socket.Imports
23+
import Network.Socket.Internal
2224
import qualified Network.Socket.Name as G
2325
import qualified Network.Socket.Syscall as G
2426
#if !defined(mingw32_HOST_OS)
@@ -30,23 +32,32 @@ import Network.Socket.Types
3032

3133
-- | Getting peer's 'SockAddr'.
3234
getPeerName :: Socket -> IO SockAddr
33-
getPeerName = G.getPeerName
35+
-- annotateWithSocket calls getPeerName.
36+
-- So, use annotateIOException directly instead of annotateWithSocket.
37+
getPeerName s = G.getPeerName s `annotateIOException` show s
3438

3539
-- | Getting my 'SockAddr'.
3640
getSocketName :: Socket -> IO SockAddr
37-
getSocketName = G.getSocketName
41+
getSocketName s = G.getSocketName s `annotateIOException` show s
3842

3943
-- | Connect to a remote socket at address.
4044
connect :: Socket -> SockAddr -> IO ()
41-
connect = G.connect
45+
connect s sa = connect' `annotateWithSocket` (s, Just sa)
46+
where
47+
connect' = do
48+
G.connect s sa
49+
labelSocket s (\label -> label ++ " " ++ show sa)
4250

4351
-- | Bind the socket to an address. The socket must not already be
4452
-- bound. The 'Family' passed to @bind@ must be the
4553
-- same as that passed to 'socket'. If the special port number
4654
-- 'defaultPort' is passed then the system assigns the next available
4755
-- use port.
4856
bind :: Socket -> SockAddr -> IO ()
49-
bind s sa = case sa of
57+
bind s sa = bind' s sa `annotateWithSocket` (s, Just sa)
58+
59+
bind' :: Socket -> SockAddr -> IO ()
60+
bind' s sa = case sa of
5061
SockAddrUnix p -> do
5162
-- gracefully handle the fact that UNIX systems don't clean up closed UNIX
5263
-- domain sockets, inspired by https://stackoverflow.com/a/13719866
@@ -64,7 +75,9 @@ bind s sa = case sa of
6475
-- socket not actually in use, remove it and retry bind
6576
void (try $ removeFile p :: IO (Either IOError ()))
6677
G.bind s sa
67-
_ -> G.bind s sa
78+
_ -> do
79+
G.bind s sa
80+
labelSocket s (\label -> label ++ " " ++ show sa)
6881

6982
-- | Accept a connection. The socket must be bound to an address and
7083
-- listening for connections. The return value is a pair @(conn,
@@ -73,14 +86,20 @@ bind s sa = case sa of
7386
-- to the socket on the other end of the connection.
7487
-- On Unix, FD_CLOEXEC is set to the new 'Socket'.
7588
accept :: Socket -> IO (Socket, SockAddr)
76-
accept = G.accept
89+
accept s = accept' `annotateWithSocket` (s, Nothing)
90+
where
91+
accept' = do
92+
r@(news, sa) <- G.accept s
93+
label <- socketLabel s
94+
labelSocket news (\_ -> label ++ " " ++ show sa)
95+
return r
7796

7897
-- | Send data to the socket. The recipient can be specified
7998
-- explicitly, so the socket need not be in a connected state.
8099
-- Returns the number of bytes sent. Applications are responsible for
81100
-- ensuring that all data has been sent.
82101
sendBufTo :: Socket -> Ptr a -> Int -> SockAddr -> IO Int
83-
sendBufTo = G.sendBufTo
102+
sendBufTo s ptr len sa = G.sendBufTo s ptr len sa `annotateWithSocket` (s, Just sa)
84103

85104
-- | Receive data from the socket, writing it into buffer instead of
86105
-- creating a new string. The socket need not be in a connected
@@ -95,7 +114,7 @@ sendBufTo = G.sendBufTo
95114
-- NOTE: blocking on Windows unless you compile with -threaded (see
96115
-- GHC ticket #1129)
97116
recvBufFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr)
98-
recvBufFrom = G.recvBufFrom
117+
recvBufFrom s ptr len = G.recvBufFrom s ptr len `annotateWithSocket` (s, Nothing)
99118

100119
-- | Send data to the socket using sendmsg(2).
101120
sendBufMsg
@@ -111,7 +130,8 @@ sendBufMsg
111130
-- ^ Message flags
112131
-> IO Int
113132
-- ^ The length actually sent
114-
sendBufMsg = G.sendBufMsg
133+
sendBufMsg s sa dats cmgs flag =
134+
G.sendBufMsg s sa dats cmgs flag `annotateWithSocket` (s, Just sa)
115135

116136
-- | Receive data from the socket using recvmsg(2).
117137
recvBufMsg
@@ -129,4 +149,14 @@ recvBufMsg
129149
-- ^ Message flags
130150
-> IO (SockAddr, Int, [Cmsg], MsgFlag)
131151
-- ^ Source address, received data, control messages and message flags
132-
recvBufMsg = G.recvBufMsg
152+
recvBufMsg s bufs len flag = G.recvBufMsg s bufs len flag `annotateWithSocket` (s, Nothing)
153+
154+
------------------------------------------------------------------------
155+
156+
annotateWithSocket :: IO a -> (Socket, Maybe SockAddr) -> IO a
157+
annotateWithSocket io (s, mpeersa) = do
158+
label <- socketLabel s
159+
let label' = case mpeersa of
160+
Nothing -> "<" ++ label ++ ">"
161+
Just peersa -> "<" ++ label ++ "> " ++ show peersa
162+
annotateIOException io label'

0 commit comments

Comments
 (0)