Skip to content

Commit 7a177c1

Browse files
kazu-yamamotokazu-yamamoto
committed
Merge refactoring
2 parents 729482c + b0c146a commit 7a177c1

File tree

4 files changed

+110
-108
lines changed

4 files changed

+110
-108
lines changed

‎Network/Socket/Info.hsc‎

Lines changed: 0 additions & 63 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,5 @@
11
{-# LANGUAGE CPP #-}
22
{-# LANGUAGE RecordWildCards #-}
3-
{-# OPTIONS_GHC -fno-warn-orphans #-}
43

54
#include "HsNet.h"
65
##include "HsNetDef.h"
@@ -447,68 +446,6 @@ unpackBits ((k,v):xs) r
447446
| r .&. v /= 0 = k : unpackBits xs (r .&. complement v)
448447
| otherwise = unpackBits xs r
449448

450-
-----------------------------------------------------------------------------
451-
-- SockAddr
452-
453-
-- |
454-
--
455-
-- >>> SockAddrInet6 80 0 (0,0,0xffff,0x01020304) 0
456-
-- [::ffff:1.2.3.4]:80
457-
instance Show SockAddr where
458-
showsPrec _ (SockAddrUnix str) = showString str
459-
showsPrec _ (SockAddrInet port ha)
460-
= showHostAddress ha
461-
. showString ":"
462-
. shows port
463-
showsPrec _ (SockAddrInet6 port _ ha6 _)
464-
= showChar '['
465-
. showHostAddress6 ha6
466-
. showString "]:"
467-
. shows port
468-
469-
470-
-- Taken from on the implementation of showIPv4 in Data.IP.Addr
471-
showHostAddress :: HostAddress -> ShowS
472-
showHostAddress ip =
473-
let (u3, u2, u1, u0) = hostAddressToTuple ip in
474-
foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0]
475-
476-
showHostAddress' :: HostAddress -> ShowS
477-
showHostAddress' ip =
478-
let (u3, u2, u1, u0) = hostAddressToTuple' ip in
479-
foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0]
480-
481-
-- Taken from showIPv6 in Data.IP.Addr.
482-
483-
-- | Show an IPv6 address in the most appropriate notation, based on recommended
484-
-- representation proposed by <http://tools.ietf.org/html/rfc5952 RFC 5952>.
485-
--
486-
-- /The implementation is completely compatible with the current implementation
487-
-- of the `inet_ntop` function in glibc./
488-
showHostAddress6 :: HostAddress6 -> ShowS
489-
showHostAddress6 ha6@(a1, a2, a3, a4)
490-
-- IPv4-Mapped IPv6 Address
491-
| a1 == 0 && a2 == 0 && a3 == 0xffff =
492-
showString "::ffff:" . showHostAddress' a4
493-
-- IPv4-Compatible IPv6 Address (exclude IPRange ::/112)
494-
| a1 == 0 && a2 == 0 && a3 == 0 && a4 >= 0x10000 =
495-
showString "::" . showHostAddress' a4
496-
-- length of longest run > 1, replace it with "::"
497-
| end - begin > 1 =
498-
showFields prefix . showString "::" . showFields suffix
499-
| otherwise =
500-
showFields fields
501-
where
502-
fields =
503-
let (u7, u6, u5, u4, u3, u2, u1, u0) = hostAddress6ToTuple ha6 in
504-
[u7, u6, u5, u4, u3, u2, u1, u0]
505-
showFields = foldr (.) id . intersperse (showChar ':') . map showHex
506-
prefix = take begin fields -- fields before "::"
507-
suffix = drop end fields -- fields after "::"
508-
begin = end + diff -- the longest run of zeros
509-
(diff, end) = minimum $
510-
scanl (\c i -> if i == 0 then c - 1 else 0) 0 fields `zip` [0..]
511-
512449
-----------------------------------------------------------------------------
513450

514451
-- | A utility function to open a socket with `AddrInfo`.

‎Network/Socket/Internal.hs‎

Lines changed: 46 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -84,11 +84,26 @@ import Network.Socket.Types
8484
-- | Throw an 'IOError' corresponding to the current socket error.
8585
throwSocketError :: String -- ^ textual description of the error location
8686
-> IO a
87+
#if defined(mingw32_HOST_OS)
88+
throwSocketError name =
89+
c_getLastError >>= throwSocketErrorCode name
90+
#else
91+
throwSocketError = throwErrno
92+
#endif
8793

8894
-- | Like 'throwSocketError', but the error code is supplied as an argument.
8995
--
9096
-- On Windows, do not use errno. Use a system error code instead.
9197
throwSocketErrorCode :: String -> CInt -> IO a
98+
#if defined(mingw32_HOST_OS)
99+
throwSocketErrorCode name rc = do
100+
pstr <- c_getWSError rc
101+
str <- peekCString pstr
102+
ioError (ioeSetErrorString (mkIOError OtherError name Nothing Nothing) str)
103+
#else
104+
throwSocketErrorCode loc errno =
105+
ioError (errnoToIOError loc (Errno errno) Nothing Nothing)
106+
#endif
92107

93108
-- | Throw an 'IOError' corresponding to the current socket error if
94109
-- the IO action returns a result of @-1@. Discards the result of the
@@ -98,6 +113,13 @@ throwSocketErrorIfMinus1_
98113
=> String -- ^ textual description of the location
99114
-> IO a -- ^ the 'IO' operation to be executed
100115
-> IO ()
116+
#if defined(mingw32_HOST_OS)
117+
throwSocketErrorIfMinus1_ name act = do
118+
_ <- throwSocketErrorIfMinus1Retry name act
119+
return ()
120+
#else
121+
throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry
122+
#endif
101123

102124
{-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-}
103125

@@ -109,6 +131,12 @@ throwSocketErrorIfMinus1Retry
109131
=> String -- ^ textual description of the location
110132
-> IO a -- ^ the 'IO' operation to be executed
111133
-> IO a
134+
#if defined(mingw32_HOST_OS)
135+
throwSocketErrorIfMinus1Retry
136+
= throwSocketErrorIfMinus1ButRetry (const False)
137+
#else
138+
throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_
139+
#endif
112140

113141
{-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> IO CInt -> IO CInt #-}
114142

@@ -136,6 +164,13 @@ throwSocketErrorIfMinus1RetryMayBlock
136164
-- immediate retry would block
137165
-> IO a -- ^ the 'IO' operation to be executed
138166
-> IO a
167+
#if defined(mingw32_HOST_OS)
168+
throwSocketErrorIfMinus1RetryMayBlock name _ act
169+
= throwSocketErrorIfMinus1Retry name act
170+
#else
171+
throwSocketErrorIfMinus1RetryMayBlock name on_block act =
172+
throwErrnoIfMinus1RetryMayBlock name act on_block
173+
#endif
139174

140175
{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock
141176
:: String -> IO b -> IO CInt -> IO CInt #-}
@@ -154,22 +189,20 @@ throwSocketErrorIfMinus1RetryMayBlockBut
154189
-- immediate retry would block
155190
-> IO a -- ^ the 'IO' operation to be executed
156191
-> IO a
157-
158-
{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock
159-
:: String -> IO b -> IO CInt -> IO CInt #-}
160-
161192
#if defined(mingw32_HOST_OS)
162-
163-
throwSocketErrorIfMinus1RetryMayBlock name _ act
164-
= throwSocketErrorIfMinus1Retry name act
165-
166193
throwSocketErrorIfMinus1RetryMayBlockBut exempt name _ act
167194
= throwSocketErrorIfMinus1ButRetry exempt name act
195+
#else
196+
throwSocketErrorIfMinus1RetryMayBlockBut _exempt name on_block act =
197+
throwErrnoIfMinus1RetryMayBlock name act on_block
198+
#endif
168199

169-
throwSocketErrorIfMinus1_ name act = do
170-
_ <- throwSocketErrorIfMinus1Retry name act
171-
return ()
200+
{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock
201+
:: String -> IO b -> IO CInt -> IO CInt #-}
202+
203+
-- ---------------------------------------------------------------------
172204

205+
#if defined(mingw32_HOST_OS)
173206
throwSocketErrorIfMinus1ButRetry :: (Eq a, Num a) =>
174207
(CInt -> Bool) -> String -> IO a -> IO a
175208
throwSocketErrorIfMinus1ButRetry exempt name act = do
@@ -189,42 +222,15 @@ throwSocketErrorIfMinus1ButRetry exempt name act = do
189222
else throwSocketError name
190223
else return r
191224

192-
throwSocketErrorIfMinus1Retry
193-
= throwSocketErrorIfMinus1ButRetry (const False)
194-
195-
throwSocketErrorCode name rc = do
196-
pstr <- c_getWSError rc
197-
str <- peekCString pstr
198-
ioError (ioeSetErrorString (mkIOError OtherError name Nothing Nothing) str)
199-
200-
throwSocketError name =
201-
c_getLastError >>= throwSocketErrorCode name
202-
203225
foreign import CALLCONV unsafe "WSAGetLastError"
204226
c_getLastError :: IO CInt
205227

206228
foreign import ccall unsafe "getWSErrorDescr"
207229
c_getWSError :: CInt -> IO (Ptr CChar)
208-
209-
#else
210-
211-
throwSocketErrorIfMinus1RetryMayBlock name on_block act =
212-
throwErrnoIfMinus1RetryMayBlock name act on_block
213-
214-
throwSocketErrorIfMinus1RetryMayBlockBut _exempt name on_block act =
215-
throwErrnoIfMinus1RetryMayBlock name act on_block
216-
217-
throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry
218-
219-
throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_
220-
221-
throwSocketError = throwErrno
222-
223-
throwSocketErrorCode loc errno =
224-
ioError (errnoToIOError loc (Errno errno) Nothing Nothing)
225-
226230
#endif
227231

232+
-- ---------------------------------------------------------------------
233+
228234
-- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with
229235
-- @EWOULDBLOCK@ or similar, wait for the socket to be read-ready,
230236
-- and try again.

‎Network/Socket/SockAddr.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -46,25 +46,25 @@ connect = G.connect
4646
-- 'defaultPort' is passed then the system assigns the next available
4747
-- use port.
4848
bind :: Socket -> SockAddr -> IO ()
49-
bind s a = case a of
49+
bind s sa = case sa of
5050
SockAddrUnix p -> do
5151
-- gracefully handle the fact that UNIX systems don't clean up closed UNIX
5252
-- domain sockets, inspired by https://stackoverflow.com/a/13719866
53-
res <- try (G.bind s a)
53+
res <- try (G.bind s sa)
5454
case res of
5555
Right () -> return ()
5656
Left e | not (isAlreadyInUseError e) -> throwIO (e :: IOException)
5757
Left e | otherwise -> do
5858
-- socket might be in use, try to connect
59-
res2 <- try (G.connect s a)
59+
res2 <- try (G.connect s sa)
6060
case res2 of
6161
Right () -> close s >> throwIO e
6262
Left e2 | not (isDoesNotExistError e2) -> throwIO (e2 :: IOException)
6363
_ -> do
6464
-- socket not actually in use, remove it and retry bind
6565
void (try $ removeFile p :: IO (Either IOError ()))
66-
G.bind s a
67-
_ -> G.bind s a
66+
G.bind s sa
67+
_ -> G.bind s sa
6868

6969
-- | Accept a connection. The socket must be bound to an address and
7070
-- listening for connections. The return value is a pair @(conn,

‎Network/Socket/Types.hsc‎

Lines changed: 59 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1084,6 +1084,65 @@ instance NFData SockAddr where
10841084
rnf (SockAddrInet6 _ _ _ _) = ()
10851085
rnf (SockAddrUnix str) = rnf str
10861086

1087+
-- |
1088+
--
1089+
-- >>> SockAddrInet6 80 0 (0,0,0xffff,0x01020304) 0
1090+
-- [::ffff:1.2.3.4]:80
1091+
instance Show SockAddr where
1092+
showsPrec _ (SockAddrUnix str) = showString str
1093+
showsPrec _ (SockAddrInet port ha)
1094+
= showHostAddress ha
1095+
. showString ":"
1096+
. shows port
1097+
showsPrec _ (SockAddrInet6 port _ ha6 _)
1098+
= showChar '['
1099+
. showHostAddress6 ha6
1100+
. showString "]:"
1101+
. shows port
1102+
1103+
1104+
-- Taken from on the implementation of showIPv4 in Data.IP.Addr
1105+
showHostAddress :: HostAddress -> ShowS
1106+
showHostAddress ip =
1107+
let (u3, u2, u1, u0) = hostAddressToTuple ip in
1108+
foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0]
1109+
1110+
showHostAddress' :: HostAddress -> ShowS
1111+
showHostAddress' ip =
1112+
let (u3, u2, u1, u0) = hostAddressToTuple' ip in
1113+
foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0]
1114+
1115+
-- Taken from showIPv6 in Data.IP.Addr.
1116+
1117+
-- | Show an IPv6 address in the most appropriate notation, based on recommended
1118+
-- representation proposed by <http://tools.ietf.org/html/rfc5952 RFC 5952>.
1119+
--
1120+
-- /The implementation is completely compatible with the current implementation
1121+
-- of the `inet_ntop` function in glibc./
1122+
showHostAddress6 :: HostAddress6 -> ShowS
1123+
showHostAddress6 ha6@(a1, a2, a3, a4)
1124+
-- IPv4-Mapped IPv6 Address
1125+
| a1 == 0 && a2 == 0 && a3 == 0xffff =
1126+
showString "::ffff:" . showHostAddress' a4
1127+
-- IPv4-Compatible IPv6 Address (exclude IPRange ::/112)
1128+
| a1 == 0 && a2 == 0 && a3 == 0 && a4 >= 0x10000 =
1129+
showString "::" . showHostAddress' a4
1130+
-- length of longest run > 1, replace it with "::"
1131+
| end - begin > 1 =
1132+
showFields prefix . showString "::" . showFields suffix
1133+
| otherwise =
1134+
showFields fields
1135+
where
1136+
fields =
1137+
let (u7, u6, u5, u4, u3, u2, u1, u0) = hostAddress6ToTuple ha6 in
1138+
[u7, u6, u5, u4, u3, u2, u1, u0]
1139+
showFields = foldr (.) id . intersperse (showChar ':') . map showHex
1140+
prefix = take begin fields -- fields before "::"
1141+
suffix = drop end fields -- fields after "::"
1142+
begin = end + diff -- the longest run of zeros
1143+
(diff, end) = minimum $
1144+
scanl (\c i -> if i == 0 then c - 1 else 0) 0 fields `zip` [0..]
1145+
10871146
-- | Is the socket address type supported on this system?
10881147
isSupportedSockAddr :: SockAddr -> Bool
10891148
isSupportedSockAddr addr = case addr of

0 commit comments

Comments
 (0)