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