-
Notifications
You must be signed in to change notification settings - Fork 185
/
Internal.hs
290 lines (235 loc) · 9.9 KB
/
Internal.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "HsNetDef.h"
-----------------------------------------------------------------------------
-- |
-- Module : Network.Socket.Internal
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/network/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : provisional
-- Portability : portable
--
-- A module containing semi-public "Network.Socket" internals.
-- Modules which extend the "Network.Socket" module will need to use
-- this module while ideally most users will be able to make do with
-- the public interface.
--
-----------------------------------------------------------------------------
module Network.Socket.Internal
(
-- * Socket error functions
throwSocketError
, throwSocketErrorCode
#if defined(mingw32_HOST_OS)
, c_getLastError
#endif
-- * Guards for socket operations that may fail
, throwSocketErrorIfMinus1_
, throwSocketErrorIfMinus1Retry
, throwSocketErrorIfMinus1Retry_
, throwSocketErrorIfMinus1RetryMayBlock
#if defined(mingw32_HOST_OS)
, throwSocketErrorIfMinus1ButRetry
#endif
-- ** 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@
-- or similar.
, throwSocketErrorWaitRead
, throwSocketErrorWaitReadBut
, throwSocketErrorWaitWrite
-- * Initialization
, withSocketsDo
-- * Null socket address type
, NullSockAddr (..)
-- * Low-level helpers
, zeroMemory
) where
import GHC.Conc (threadWaitRead, threadWaitWrite)
#if defined(mingw32_HOST_OS)
import Control.Exception (evaluate)
import System.IO.Unsafe (unsafePerformIO)
# if __GLASGOW_HASKELL__ >= 707
import GHC.IO.Exception (IOErrorType(..))
# else
import GHC.IOBase (IOErrorType(..))
# endif
import System.IO.Error (ioeSetErrorString, mkIOError)
#else
import Foreign.C.Error (throwErrno, throwErrnoIfMinus1Retry,
throwErrnoIfMinus1RetryMayBlock, throwErrnoIfMinus1_,
Errno(..), errnoToIOError)
#endif
#if defined(mingw32_HOST_OS)
import Network.Socket.Cbits
#endif
import Network.Socket.Imports
import Network.Socket.Types
-- ---------------------------------------------------------------------
-- Guards for socket operations that may fail
-- | Throw an 'IOError' corresponding to the current socket error.
throwSocketError :: String -- ^ textual description of the error location
-> IO a
-- | Like 'throwSocketError', but the error code is supplied as an argument.
--
-- On Windows, do not use errno. Use a system error code instead.
throwSocketErrorCode :: String -> CInt -> IO a
-- | Throw an 'IOError' corresponding to the current socket error if
-- the IO action returns a result of @-1@. Discards the result of the
-- IO action after error handling.
throwSocketErrorIfMinus1_
:: (Eq a, Num a)
=> String -- ^ textual description of the location
-> IO a -- ^ the 'IO' operation to be executed
-> IO ()
{-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-}
-- | Throw an 'IOError' corresponding to the current socket error if
-- the IO action returns a result of @-1@, but retries in case of an
-- interrupted operation.
throwSocketErrorIfMinus1Retry
:: (Eq a, Num a)
=> String -- ^ textual description of the location
-> IO a -- ^ the 'IO' operation to be executed
-> IO a
{-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> IO CInt -> IO CInt #-}
-- | Throw an 'IOError' corresponding to the current socket error if
-- the IO action returns a result of @-1@, but retries in case of an
-- interrupted operation. Discards the result of the IO action after
-- error handling.
throwSocketErrorIfMinus1Retry_
:: (Eq a, Num a)
=> String -- ^ textual description of the location
-> IO a -- ^ the 'IO' operation to be executed
-> IO ()
throwSocketErrorIfMinus1Retry_ loc m =
void $ throwSocketErrorIfMinus1Retry loc m
{-# SPECIALIZE throwSocketErrorIfMinus1Retry_ :: String -> IO CInt -> IO () #-}
-- | Throw an 'IOError' corresponding to the current socket error if
-- the IO action returns a result of @-1@, but retries in case of an
-- interrupted operation. Checks for operations that would block and
-- executes an alternative action before retrying in that case.
throwSocketErrorIfMinus1RetryMayBlock
:: (Eq a, Num a)
=> String -- ^ textual description of the location
-> IO b -- ^ action to execute before retrying if an
-- immediate retry would block
-> IO a -- ^ the 'IO' operation to be executed
-> IO a
{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock
:: String -> IO b -> IO CInt -> IO CInt #-}
-- | Throw an 'IOError' corresponding to the current socket error if
-- the IO action returns a result of @-1@, but retries in case of an
-- interrupted operation. Checks for operations that would block and
-- executes an alternative action before retrying in that case. If the error
-- is one handled by the exempt filter then ignore it and return the error code.
throwSocketErrorIfMinus1RetryMayBlockBut
:: (Eq a, Num a)
=> (CInt -> Bool) -- ^ exception exempt filter
-> String -- ^ textual description of the location
-> IO b -- ^ action to execute before retrying if an
-- immediate retry would block
-> IO a -- ^ the 'IO' operation to be executed
-> IO a
{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock
:: String -> IO b -> IO CInt -> IO CInt #-}
#if defined(mingw32_HOST_OS)
throwSocketErrorIfMinus1RetryMayBlock name _ act
= throwSocketErrorIfMinus1Retry name act
throwSocketErrorIfMinus1RetryMayBlockBut exempt name _ act
= throwSocketErrorIfMinus1ButRetry exempt name act
throwSocketErrorIfMinus1_ name act = do
_ <- throwSocketErrorIfMinus1Retry name act
return ()
throwSocketErrorIfMinus1ButRetry :: (Eq a, Num a) =>
(CInt -> Bool) -> String -> IO a -> IO a
throwSocketErrorIfMinus1ButRetry exempt name act = do
r <- act
if (r == -1)
then do
rc <- c_getLastError
if rc == wsaNotInitialized then do
withSocketsDo (return ())
r' <- act
if (r' == -1)
then throwSocketError name
else return r'
else
if (exempt rc)
then return r
else throwSocketError name
else return r
throwSocketErrorIfMinus1Retry
= throwSocketErrorIfMinus1ButRetry (const False)
throwSocketErrorCode name rc = do
pstr <- c_getWSError rc
str <- peekCString pstr
ioError (ioeSetErrorString (mkIOError OtherError name Nothing Nothing) str)
throwSocketError name =
c_getLastError >>= throwSocketErrorCode name
foreign import CALLCONV unsafe "WSAGetLastError"
c_getLastError :: IO CInt
foreign import ccall unsafe "getWSErrorDescr"
c_getWSError :: CInt -> IO (Ptr CChar)
#else
throwSocketErrorIfMinus1RetryMayBlock name on_block act =
throwErrnoIfMinus1RetryMayBlock name act on_block
throwSocketErrorIfMinus1RetryMayBlockBut _exempt name on_block act =
throwErrnoIfMinus1RetryMayBlock name act on_block
throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry
throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_
throwSocketError = throwErrno
throwSocketErrorCode loc errno =
ioError (errnoToIOError loc (Errno errno) Nothing Nothing)
#endif
-- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with
-- @EWOULDBLOCK@ or similar, wait for the socket to be read-ready,
-- and try again.
throwSocketErrorWaitRead :: (Eq a, Num a) => Socket -> String -> IO a -> IO a
throwSocketErrorWaitRead s name io = withFdSocket s $ \fd ->
throwSocketErrorIfMinus1RetryMayBlock name
(threadWaitRead $ fromIntegral fd) io
-- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with
-- @EWOULDBLOCK@ or similar, wait for the socket to be read-ready,
-- and try again. If it fails with the error the user was expecting then
-- ignore the error
throwSocketErrorWaitReadBut :: (Eq a, Num a) => (CInt -> Bool) -> Socket -> String -> IO a -> IO a
throwSocketErrorWaitReadBut exempt s name io = withFdSocket s $ \fd ->
throwSocketErrorIfMinus1RetryMayBlockBut exempt name
(threadWaitRead $ fromIntegral fd) io
-- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with
-- @EWOULDBLOCK@ or similar, wait for the socket to be write-ready,
-- and try again.
throwSocketErrorWaitWrite :: (Eq a, Num a) => Socket -> String -> IO a -> IO a
throwSocketErrorWaitWrite s name io = withFdSocket s $ \fd ->
throwSocketErrorIfMinus1RetryMayBlock name
(threadWaitWrite $ fromIntegral fd) io
-- ---------------------------------------------------------------------------
-- WinSock support
{-| With older versions of the @network@ library (version 2.6.0.2 or earlier)
on Windows operating systems,
the networking subsystem must be initialised using 'withSocketsDo' before
any networking operations can be used. eg.
> main = withSocketsDo $ do {...}
It is fine to nest calls to 'withSocketsDo', and to perform networking operations
after 'withSocketsDo' has returned.
'withSocketsDo' is not necessary for the current network library.
However, for compatibility with older versions on Windows, it is good practice
to always call 'withSocketsDo' (it's very cheap).
-}
{-# INLINE withSocketsDo #-}
withSocketsDo :: IO a -> IO a
#if defined(mingw32_HOST_OS)
withSocketsDo act = evaluate withSocketsInit >> act
{-# NOINLINE withSocketsInit #-}
withSocketsInit :: ()
-- Use a CAF to make forcing it do initialisation once, but subsequent forces will be cheap
withSocketsInit = unsafePerformIO $ do
x <- initWinSock
when (x /= 0) $ ioError $
userError "Network.Socket.Internal.withSocketsDo: Failed to initialise WinSock"
foreign import ccall unsafe "initWinSock" initWinSock :: IO Int
#else
withSocketsDo x = x
#endif