{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "HsNetDef.h"
module Network.Socket.Internal
(
throwSocketError
, throwSocketErrorCode
#if defined(mingw32_HOST_OS)
, c_getLastError
#endif
, throwSocketErrorIfMinus1_
, throwSocketErrorIfMinus1Retry
, throwSocketErrorIfMinus1Retry_
, throwSocketErrorIfMinus1RetryMayBlock
, throwSocketErrorWaitRead
, throwSocketErrorWaitWrite
, withSocketsDo
, 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
throwSocketError :: String
-> IO a
throwSocketErrorCode :: String -> CInt -> IO a
throwSocketErrorIfMinus1_
:: (Eq a, Num a)
=> String
-> IO a
-> IO ()
{-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-}
throwSocketErrorIfMinus1Retry
:: (Eq a, Num a)
=> String
-> IO a
-> IO a
{-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> IO CInt -> IO CInt #-}
throwSocketErrorIfMinus1Retry_
:: (Eq a, Num a)
=> String
-> IO a
-> IO ()
throwSocketErrorIfMinus1Retry_ loc m =
void $ throwSocketErrorIfMinus1Retry loc m
{-# SPECIALIZE throwSocketErrorIfMinus1Retry_ :: String -> IO CInt -> IO () #-}
throwSocketErrorIfMinus1RetryMayBlock
:: (Eq a, Num a)
=> String
-> IO b
-> IO a
-> IO a
{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock
:: String -> IO b -> IO CInt -> IO CInt #-}
#if defined(mingw32_HOST_OS)
throwSocketErrorIfMinus1RetryMayBlock name _ act
= throwSocketErrorIfMinus1Retry name act
throwSocketErrorIfMinus1_ name act = do
_ <- throwSocketErrorIfMinus1Retry name act
return ()
throwSocketErrorIfMinus1Retry 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
throwSocketError name
else return r
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
throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry
throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_
throwSocketError = throwErrno
throwSocketErrorCode loc errno =
ioError (errnoToIOError loc (Errno errno) Nothing Nothing)
#endif
throwSocketErrorWaitRead :: (Eq a, Num a) => Socket -> String -> IO a -> IO a
throwSocketErrorWaitRead s name io = withFdSocket s $ \fd ->
throwSocketErrorIfMinus1RetryMayBlock name
(threadWaitRead $ fromIntegral fd) io
throwSocketErrorWaitWrite :: (Eq a, Num a) => Socket -> String -> IO a -> IO a
throwSocketErrorWaitWrite s name io = withFdSocket s $ \fd ->
throwSocketErrorIfMinus1RetryMayBlock name
(threadWaitWrite $ fromIntegral fd) io
{-# INLINE withSocketsDo #-}
withSocketsDo :: IO a -> IO a
#if defined(mingw32_HOST_OS)
withSocketsDo act = evaluate withSocketsInit >> act
{-# NOINLINE withSocketsInit #-}
withSocketsInit :: ()
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