{-# LANGUAGE CPP #-}
#include "HsNetDef.h"
module Network.Socket.Syscall where
import Foreign.Marshal.Utils (with)
import qualified Control.Exception as E
# if defined(mingw32_HOST_OS)
import System.IO.Error (catchIOError)
#endif
#if defined(mingw32_HOST_OS)
import Foreign (FunPtr)
import GHC.Conc (asyncDoProc)
#else
import Foreign.C.Error (getErrno, eINTR, eINPROGRESS)
import GHC.Conc (threadWaitWrite)
#endif
#ifdef HAVE_ADVANCED_SOCKET_FLAGS
import Network.Socket.Cbits
#else
import Network.Socket.Fcntl
#endif
import Network.Socket.Imports
import Network.Socket.Internal
import Network.Socket.Options
import Network.Socket.Types
socket :: Family
-> SocketType
-> ProtocolNumber
-> IO Socket
socket :: Family -> SocketType -> CInt -> IO Socket
socket Family
family SocketType
stype CInt
protocol = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError IO CInt
create CInt -> IO CInt
c_close forall a b. (a -> b) -> a -> b
$ \CInt
fd -> do
forall {m :: * -> *} {p}. Monad m => p -> m ()
setNonBlock CInt
fd
Socket
s <- CInt -> IO Socket
mkSocket CInt
fd
Socket -> IO ()
unsetIPv6Only Socket
s
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
s
where
create :: IO CInt
create = do
let c_stype :: CInt
c_stype = CInt -> CInt
modifyFlag forall a b. (a -> b) -> a -> b
$ SocketType -> CInt
packSocketType SocketType
stype
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwSocketErrorIfMinus1Retry String
"Network.Socket.socket" forall a b. (a -> b) -> a -> b
$
CInt -> CInt -> CInt -> IO CInt
c_socket (Family -> CInt
packFamily Family
family) CInt
c_stype CInt
protocol
#ifdef HAVE_ADVANCED_SOCKET_FLAGS
modifyFlag :: CInt -> CInt
modifyFlag CInt
c_stype = CInt
c_stype forall a. Bits a => a -> a -> a
.|. CInt
sockNonBlock
#else
modifyFlag c_stype = c_stype
#endif
#ifdef HAVE_ADVANCED_SOCKET_FLAGS
setNonBlock :: p -> m ()
setNonBlock p
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
setNonBlock fd = setNonBlockIfNeeded fd
#endif
#if HAVE_DECL_IPV6_V6ONLY
unsetIPv6Only :: Socket -> IO ()
unsetIPv6Only Socket
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Family
family forall a. Eq a => a -> a -> Bool
== Family
AF_INET6 Bool -> Bool -> Bool
&& SocketType
stype forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SocketType
Stream, SocketType
Datagram]) forall a b. (a -> b) -> a -> b
$
# if defined(mingw32_HOST_OS)
setSocketOption s IPv6Only 0 `catchIOError` \_ -> return ()
# elif defined(openbsd_HOST_OS)
return ()
# else
Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
s SocketOption
IPv6Only Int
0
# endif
#else
unsetIPv6Only _ = return ()
#endif
bind :: SocketAddress sa => Socket -> sa -> IO ()
bind :: forall sa. SocketAddress sa => Socket -> sa -> IO ()
bind Socket
s sa
sa = forall sa a.
SocketAddress sa =>
sa -> (Ptr sa -> Int -> IO a) -> IO a
withSocketAddress sa
sa forall a b. (a -> b) -> a -> b
$ \Ptr sa
p_sa Int
siz -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
s forall a b. (a -> b) -> a -> b
$ \CInt
fd -> do
let sz :: CInt
sz = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
siz
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwSocketErrorIfMinus1Retry String
"Network.Socket.bind" forall a b. (a -> b) -> a -> b
$ forall sa. CInt -> Ptr sa -> CInt -> IO CInt
c_bind CInt
fd Ptr sa
p_sa CInt
sz
connect :: SocketAddress sa => Socket -> sa -> IO ()
connect :: forall sa. SocketAddress sa => Socket -> sa -> IO ()
connect Socket
s sa
sa = forall a. IO a -> IO a
withSocketsDo forall a b. (a -> b) -> a -> b
$ forall sa a.
SocketAddress sa =>
sa -> (Ptr sa -> Int -> IO a) -> IO a
withSocketAddress sa
sa forall a b. (a -> b) -> a -> b
$ \Ptr sa
p_sa Int
sz ->
forall sa. SocketAddress sa => Socket -> Ptr sa -> CInt -> IO ()
connectLoop Socket
s Ptr sa
p_sa (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz)
connectLoop :: SocketAddress sa => Socket -> Ptr sa -> CInt -> IO ()
connectLoop :: forall sa. SocketAddress sa => Socket -> Ptr sa -> CInt -> IO ()
connectLoop Socket
s Ptr sa
p_sa CInt
sz = forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
s forall a b. (a -> b) -> a -> b
$ \CInt
fd -> CInt -> IO ()
loop CInt
fd
where
errLoc :: String
errLoc = String
"Network.Socket.connect: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Socket
s
loop :: CInt -> IO ()
loop CInt
fd = do
CInt
r <- forall sa. CInt -> Ptr sa -> CInt -> IO CInt
c_connect CInt
fd Ptr sa
p_sa CInt
sz
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r forall a. Eq a => a -> a -> Bool
== -CInt
1) forall a b. (a -> b) -> a -> b
$ do
#if defined(mingw32_HOST_OS)
throwSocketError errLoc
#else
Errno
err <- IO Errno
getErrno
case () of
()
_ | Errno
err forall a. Eq a => a -> a -> Bool
== Errno
eINTR -> CInt -> IO ()
loop CInt
fd
()
_ | Errno
err forall a. Eq a => a -> a -> Bool
== Errno
eINPROGRESS -> IO ()
connectBlocked
()
_otherwise -> forall a. String -> IO a
throwSocketError String
errLoc
connectBlocked :: IO ()
connectBlocked = do
forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
s forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
threadWaitWrite forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
Int
err <- Socket -> SocketOption -> IO Int
getSocketOption Socket
s SocketOption
SoError
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
err forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$ forall a. String -> CInt -> IO a
throwSocketErrorCode String
errLoc (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
err)
#endif
listen :: Socket -> Int -> IO ()
listen :: Socket -> Int -> IO ()
listen Socket
s Int
backlog = forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
s forall a b. (a -> b) -> a -> b
$ \CInt
fd -> do
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwSocketErrorIfMinus1Retry_ String
"Network.Socket.listen" forall a b. (a -> b) -> a -> b
$
CInt -> CInt -> IO CInt
c_listen CInt
fd forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
backlog
accept :: SocketAddress sa => Socket -> IO (Socket, sa)
accept :: forall sa. SocketAddress sa => Socket -> IO (Socket, sa)
accept Socket
listing_sock = forall sa a. SocketAddress sa => (Ptr sa -> Int -> IO a) -> IO a
withNewSocketAddress forall a b. (a -> b) -> a -> b
$ \Ptr sa
new_sa Int
sz ->
forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
listing_sock forall a b. (a -> b) -> a -> b
$ \CInt
listing_fd -> do
Socket
new_sock <- forall {a} {sa}. Integral a => CInt -> Ptr sa -> a -> IO CInt
callAccept CInt
listing_fd Ptr sa
new_sa Int
sz forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO Socket
mkSocket
sa
new_addr <- forall sa. SocketAddress sa => Ptr sa -> IO sa
peekSocketAddress Ptr sa
new_sa
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
new_sock, sa
new_addr)
where
#if defined(mingw32_HOST_OS)
callAccept fd sa sz
| threaded = with (fromIntegral sz) $ \ ptr_len ->
throwSocketErrorIfMinus1Retry "Network.Socket.accept" $
c_accept_safe fd sa ptr_len
| otherwise = do
paramData <- c_newAcceptParams fd (fromIntegral sz) sa
rc <- asyncDoProc c_acceptDoProc paramData
new_fd <- c_acceptNewSock paramData
c_free paramData
when (rc /= 0) $
throwSocketErrorCode "Network.Socket.accept" (fromIntegral rc)
return new_fd
#else
callAccept :: CInt -> Ptr sa -> a -> IO CInt
callAccept CInt
fd Ptr sa
sa a
sz = forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
sz) forall a b. (a -> b) -> a -> b
$ \ Ptr CInt
ptr_len -> do
# ifdef HAVE_ADVANCED_SOCKET_FLAGS
forall a. (Eq a, Num a) => Socket -> String -> IO a -> IO a
throwSocketErrorWaitRead Socket
listing_sock String
"Network.Socket.accept"
(forall sa. CInt -> Ptr sa -> Ptr CInt -> CInt -> IO CInt
c_accept4 CInt
fd Ptr sa
sa Ptr CInt
ptr_len (CInt
sockNonBlock forall a. Bits a => a -> a -> a
.|. CInt
sockCloexec))
# else
new_fd <- throwSocketErrorWaitRead listing_sock "Network.Socket.accept"
(c_accept fd sa ptr_len)
setNonBlockIfNeeded new_fd
setCloseOnExecIfNeeded new_fd
return new_fd
# endif /* HAVE_ADVANCED_SOCKET_FLAGS */
#endif
foreign import CALLCONV unsafe "socket"
c_socket :: CInt -> CInt -> CInt -> IO CInt
foreign import CALLCONV unsafe "bind"
c_bind :: CInt -> Ptr sa -> CInt -> IO CInt
foreign import CALLCONV SAFE_ON_WIN "connect"
c_connect :: CInt -> Ptr sa -> CInt -> IO CInt
foreign import CALLCONV unsafe "listen"
c_listen :: CInt -> CInt -> IO CInt
#ifdef HAVE_ADVANCED_SOCKET_FLAGS
foreign import CALLCONV unsafe "accept4"
c_accept4 :: CInt -> Ptr sa -> Ptr CInt -> CInt -> IO CInt
#else
foreign import CALLCONV unsafe "accept"
c_accept :: CInt -> Ptr sa -> Ptr CInt -> IO CInt
#endif
#if defined(mingw32_HOST_OS)
foreign import CALLCONV safe "accept"
c_accept_safe :: CInt -> Ptr sa -> Ptr CInt -> IO CInt
foreign import ccall unsafe "rtsSupportsBoundThreads"
threaded :: Bool
foreign import ccall unsafe "HsNet.h acceptNewSock"
c_acceptNewSock :: Ptr () -> IO CInt
foreign import ccall unsafe "HsNet.h newAcceptParams"
c_newAcceptParams :: CInt -> CInt -> Ptr a -> IO (Ptr ())
foreign import ccall unsafe "HsNet.h &acceptDoProc"
c_acceptDoProc :: FunPtr (Ptr () -> IO Int)
foreign import ccall unsafe "free"
c_free:: Ptr a -> IO ()
#endif