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