    {-# 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

    -- ----------------------------------------------------------------------------
    -- On Windows, our sockets are not put in non-blocking mode (non-blocking
    -- is not supported for regular file descriptors on Windows, and it would
    -- be a pain to support it only for sockets).  So there are two cases:
    --
    --  - the threaded RTS uses safe calls for socket operations to get
    --    non-blocking I/O, just like the rest of the I/O library
    --
    --  - with the non-threaded RTS, only some operations on sockets will be
    --    non-blocking.  Reads and writes go through the normal async I/O
    --    system.  accept() uses asyncDoProc so is non-blocking.  A handful
    --    of others (recvFrom, sendFd, recvFd) will block all threads - if this
    --    is a problem, -threaded is the workaround.
    --

    -----------------------------------------------------------------------------
    -- Connection Functions

    -- In the following connection and binding primitives.  The names of
    -- the equivalent C functions have been preserved where possible. It
    -- should be noted that some of these names used in the C library,
    -- \tr{bind} in particular, have a different meaning to many Haskell
    -- programmers and have thus been renamed by appending the prefix
    -- Socket.

    -- | Create a new socket using the given address family, socket type
    -- and protocol number.  The address family is usually 'AF_INET',
    -- 'AF_INET6', or 'AF_UNIX'.  The socket type is usually 'Stream' or
    -- 'Datagram'.  The protocol number is usually 'defaultProtocol'.
    -- If 'AF_INET6' is used and the socket type is 'Stream' or 'Datagram',
    -- the 'IPv6Only' socket option is set to 0 so that both IPv4 and IPv6
    -- can be handled with one socket.
    --
    -- >>> import Network.Socket
    -- >>> let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream }
    -- >>> addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.1") (Just "5000")
    -- >>> sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
    -- >>> Network.Socket.bind sock (addrAddress addr)
    -- >>> getSocketName sock
    -- 127.0.0.1:5000
    socket :: Family         -- Family Name (usually AF_INET)
           -> SocketType     -- Socket Type (usually Stream)
           -> ProtocolNumber -- Protocol Number (getProtocolByName to find value)
           -> IO Socket      -- Unconnected Socket
    socket :: Family -> SocketType -> ProtocolNumber -> IO Socket
    socket family :: Family
    family stype :: SocketType
    stype protocol :: ProtocolNumber
    protocol = IO ProtocolNumber
    -> (ProtocolNumber -> IO ProtocolNumber)
    -> (ProtocolNumber -> IO Socket)
    -> IO Socket
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    E.bracketOnError IO ProtocolNumber
    create ProtocolNumber -> IO ProtocolNumber
    c_close ((ProtocolNumber -> IO Socket) -> IO Socket)
    -> (ProtocolNumber -> IO Socket) -> IO Socket
    forall a b. (a -> b) -> a -> b
    $ \fd :: ProtocolNumber
    fd -> do
        -- Let's ensure that the socket (file descriptor) is closed even on
        -- asynchronous exceptions.
        ProtocolNumber -> IO ()
    forall (m :: * -> *) p. Monad m => p -> m ()
    setNonBlock ProtocolNumber
    fd
        Socket
    s <- ProtocolNumber -> IO Socket
    mkSocket ProtocolNumber
    fd
        -- This socket is not managed by the IO manager yet.
        -- So, we don't have to call "close" which uses "closeFdWith".
        Socket -> IO ()
    unsetIPv6Only Socket
    s
        Socket -> IO Socket
    forall (m :: * -> *) a. Monad m => a -> m a
    return Socket
    s
      where
        create :: IO ProtocolNumber
    create = do
            ProtocolNumber
    c_stype <- ProtocolNumber -> ProtocolNumber
    modifyFlag (ProtocolNumber -> ProtocolNumber)
    -> IO ProtocolNumber -> IO ProtocolNumber
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> SocketType -> IO ProtocolNumber
    packSocketTypeOrThrow "socket" SocketType
    stype
            String -> IO ProtocolNumber -> IO ProtocolNumber
    forall a. (Eq a, Num a) => String -> IO a -> IO a
    throwSocketErrorIfMinus1Retry "Network.Socket.socket" (IO ProtocolNumber -> IO ProtocolNumber)
    -> IO ProtocolNumber -> IO ProtocolNumber
    forall a b. (a -> b) -> a -> b
    $
                ProtocolNumber
    -> ProtocolNumber -> ProtocolNumber -> IO ProtocolNumber
    c_socket (Family -> ProtocolNumber
    packFamily Family
    family) ProtocolNumber
    c_stype ProtocolNumber
    protocol

    #ifdef HAVE_ADVANCED_SOCKET_FLAGS
        modifyFlag :: ProtocolNumber -> ProtocolNumber
    modifyFlag c_stype :: ProtocolNumber
    c_stype = ProtocolNumber
    c_stype ProtocolNumber -> ProtocolNumber -> ProtocolNumber
    forall a. Bits a => a -> a -> a
    .|. ProtocolNumber
    sockNonBlock
    #else
        modifyFlag c_stype = c_stype
    #endif

    #ifdef HAVE_ADVANCED_SOCKET_FLAGS
        setNonBlock :: p -> m ()
    setNonBlock _ = () -> m ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    #else
        setNonBlock fd = setNonBlockIfNeeded fd
    #endif

    #if HAVE_DECL_IPV6_V6ONLY
        unsetIPv6Only :: Socket -> IO ()
    unsetIPv6Only s :: Socket
    s = Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Family
    family Family -> Family -> Bool
    forall a. Eq a => a -> a -> Bool
    == Family
    AF_INET6 Bool -> Bool -> Bool
    && SocketType
    stype SocketType -> [SocketType] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [SocketType
    Stream, SocketType
    Datagram]) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
    # if defined(mingw32_HOST_OS)
          -- The IPv6Only option is only supported on Windows Vista and later,
          -- so trying to change it might throw an error.
          setSocketOption s IPv6Only 0 `catchIOError` \_ -> return ()
    # elif defined(__OpenBSD__)
          -- don't change IPv6Only
          return ()
    # else
          -- The default value of the IPv6Only option is platform specific,
          -- so we explicitly set it to 0 to provide a common default.
          Socket -> SocketOption -> Int -> IO ()
    setSocketOption Socket
    s SocketOption
    IPv6Only 0
    # endif
    #else
        unsetIPv6Only _ = return ()
    #endif

    -----------------------------------------------------------------------------
    -- Binding a socket

    -- | Bind the socket to an address. The socket must not already be
    -- bound.  The 'Family' passed to @bind@ must be the
    -- same as that passed to 'socket'.  If the special port number
    -- 'defaultPort' is passed then the system assigns the next available
    -- use port.
    bind :: SocketAddress sa => Socket -> sa -> IO ()
    bind :: Socket -> sa -> IO ()
    bind s :: Socket
    s sa :: sa
    sa = sa -> (Ptr sa -> Int -> IO ()) -> IO ()
    forall sa a.
    SocketAddress sa =>
    sa -> (Ptr sa -> Int -> IO a) -> IO a
    withSocketAddress sa
    sa ((Ptr sa -> Int -> IO ()) -> IO ())
    -> (Ptr sa -> Int -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \p_sa :: Ptr sa
    p_sa siz :: Int
    siz -> IO ProtocolNumber -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO ProtocolNumber -> IO ()) -> IO ProtocolNumber -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Socket
    -> (ProtocolNumber -> IO ProtocolNumber) -> IO ProtocolNumber
    forall r. Socket -> (ProtocolNumber -> IO r) -> IO r
    withFdSocket Socket
    s ((ProtocolNumber -> IO ProtocolNumber) -> IO ProtocolNumber)
    -> (ProtocolNumber -> IO ProtocolNumber) -> IO ProtocolNumber
    forall a b. (a -> b) -> a -> b
    $ \fd :: ProtocolNumber
    fd -> do
      let sz :: ProtocolNumber
    sz = Int -> ProtocolNumber
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    siz
      String -> IO ProtocolNumber -> IO ProtocolNumber
    forall a. (Eq a, Num a) => String -> IO a -> IO a
    throwSocketErrorIfMinus1Retry "Network.Socket.bind" (IO ProtocolNumber -> IO ProtocolNumber)
    -> IO ProtocolNumber -> IO ProtocolNumber
    forall a b. (a -> b) -> a -> b
    $ ProtocolNumber -> Ptr sa -> ProtocolNumber -> IO ProtocolNumber
    forall sa.
    ProtocolNumber -> Ptr sa -> ProtocolNumber -> IO ProtocolNumber
    c_bind ProtocolNumber
    fd Ptr sa
    p_sa ProtocolNumber
    sz

    -----------------------------------------------------------------------------
    -- Connecting a socket

    -- | Connect to a remote socket at address.
    connect :: SocketAddress sa => Socket -> sa -> IO ()
    connect :: Socket -> sa -> IO ()
    connect s :: Socket
    s sa :: sa
    sa = IO () -> IO ()
    forall a. IO a -> IO a
    withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ sa -> (Ptr sa -> Int -> IO ()) -> IO ()
    forall sa a.
    SocketAddress sa =>
    sa -> (Ptr sa -> Int -> IO a) -> IO a
    withSocketAddress sa
    sa ((Ptr sa -> Int -> IO ()) -> IO ())
    -> (Ptr sa -> Int -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \p_sa :: Ptr sa
    p_sa sz :: Int
    sz ->
        Socket -> Ptr sa -> ProtocolNumber -> IO ()
    forall sa.
    SocketAddress sa =>
    Socket -> Ptr sa -> ProtocolNumber -> IO ()
    connectLoop Socket
    s Ptr sa
    p_sa (Int -> ProtocolNumber
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    sz)

    connectLoop :: SocketAddress sa => Socket -> Ptr sa -> CInt -> IO ()
    connectLoop :: Socket -> Ptr sa -> ProtocolNumber -> IO ()
    connectLoop s :: Socket
    s p_sa :: Ptr sa
    p_sa sz :: ProtocolNumber
    sz = Socket -> (ProtocolNumber -> IO ()) -> IO ()
    forall r. Socket -> (ProtocolNumber -> IO r) -> IO r
    withFdSocket Socket
    s ((ProtocolNumber -> IO ()) -> IO ())
    -> (ProtocolNumber -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \fd :: ProtocolNumber
    fd -> ProtocolNumber -> IO ()
    loop ProtocolNumber
    fd
      where
        errLoc :: String
    errLoc = "Network.Socket.connect: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Socket -> String
    forall a. Show a => a -> String
    show Socket
    s
        loop :: ProtocolNumber -> IO ()
    loop fd :: ProtocolNumber
    fd = do
           ProtocolNumber
    r <- ProtocolNumber -> Ptr sa -> ProtocolNumber -> IO ProtocolNumber
    forall sa.
    ProtocolNumber -> Ptr sa -> ProtocolNumber -> IO ProtocolNumber
    c_connect ProtocolNumber
    fd Ptr sa
    p_sa ProtocolNumber
    sz
           Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (ProtocolNumber
    r ProtocolNumber -> ProtocolNumber -> Bool
    forall a. Eq a => a -> a -> Bool
    == -1) (IO () -> IO ()) -> IO () -> IO ()
    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 Errno -> Errno -> Bool
    forall a. Eq a => a -> a -> Bool
    == Errno
    eINTR       -> ProtocolNumber -> IO ()
    loop ProtocolNumber
    fd
                 _ | Errno
    err Errno -> Errno -> Bool
    forall a. Eq a => a -> a -> Bool
    == Errno
    eINPROGRESS -> IO ()
    connectBlocked
    --           _ | err == eAGAIN      -> connectBlocked
                 _otherwise :: ()
    _otherwise             -> String -> IO ()
    forall a. String -> IO a
    throwSocketError String
    errLoc

        connectBlocked :: IO ()
    connectBlocked = do
           Socket -> (ProtocolNumber -> IO ()) -> IO ()
    forall r. Socket -> (ProtocolNumber -> IO r) -> IO r
    withFdSocket Socket
    s ((ProtocolNumber -> IO ()) -> IO ())
    -> (ProtocolNumber -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Fd -> IO ()
    threadWaitWrite (Fd -> IO ()) -> (ProtocolNumber -> Fd) -> ProtocolNumber -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ProtocolNumber -> Fd
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral
           Int
    err <- Socket -> SocketOption -> IO Int
    getSocketOption Socket
    s SocketOption
    SoError
           Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    err Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= 0) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String -> ProtocolNumber -> IO ()
    forall a. String -> ProtocolNumber -> IO a
    throwSocketErrorCode String
    errLoc (Int -> ProtocolNumber
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    err)
    #endif

    -----------------------------------------------------------------------------
    -- Listen

    -- | Listen for connections made to the socket.  The second argument
    -- specifies the maximum number of queued connections and should be at
    -- least 1; the maximum value is system-dependent (usually 5).
    listen :: Socket -> Int -> IO ()
    listen :: Socket -> Int -> IO ()
    listen s :: Socket
    s backlog :: Int
    backlog = Socket -> (ProtocolNumber -> IO ()) -> IO ()
    forall r. Socket -> (ProtocolNumber -> IO r) -> IO r
    withFdSocket Socket
    s ((ProtocolNumber -> IO ()) -> IO ())
    -> (ProtocolNumber -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \fd :: ProtocolNumber
    fd -> do
        String -> IO ProtocolNumber -> IO ()
    forall a. (Eq a, Num a) => String -> IO a -> IO ()
    throwSocketErrorIfMinus1Retry_ "Network.Socket.listen" (IO ProtocolNumber -> IO ()) -> IO ProtocolNumber -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            ProtocolNumber -> ProtocolNumber -> IO ProtocolNumber
    c_listen ProtocolNumber
    fd (ProtocolNumber -> IO ProtocolNumber)
    -> ProtocolNumber -> IO ProtocolNumber
    forall a b. (a -> b) -> a -> b
    $ Int -> ProtocolNumber
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    backlog

    -----------------------------------------------------------------------------
    -- Accept
    --
    -- A call to `accept' only returns when data is available on the given
    -- socket, unless the socket has been set to non-blocking.  It will
    -- return a new socket which should be used to read the incoming data and
    -- should then be closed. Using the socket returned by `accept' allows
    -- incoming requests to be queued on the original socket.

    -- | Accept a connection.  The socket must be bound to an address and
    -- listening for connections.  The return value is a pair @(conn,
    -- address)@ where @conn@ is a new socket object usable to send and
    -- receive data on the connection, and @address@ is the address bound
    -- to the socket on the other end of the connection.
    -- On Unix, FD_CLOEXEC is set to the new 'Socket'.
    accept :: SocketAddress sa => Socket -> IO (Socket, sa)
    accept :: Socket -> IO (Socket, sa)
    accept listing_sock :: Socket
    listing_sock = (Ptr sa -> Int -> IO (Socket, sa)) -> IO (Socket, sa)
    forall sa a. SocketAddress sa => (Ptr sa -> Int -> IO a) -> IO a
    withNewSocketAddress ((Ptr sa -> Int -> IO (Socket, sa)) -> IO (Socket, sa))
    -> (Ptr sa -> Int -> IO (Socket, sa)) -> IO (Socket, sa)
    forall a b. (a -> b) -> a -> b
    $ \new_sa :: Ptr sa
    new_sa sz :: Int
    sz ->
        Socket -> (ProtocolNumber -> IO (Socket, sa)) -> IO (Socket, sa)
    forall r. Socket -> (ProtocolNumber -> IO r) -> IO r
    withFdSocket Socket
    listing_sock ((ProtocolNumber -> IO (Socket, sa)) -> IO (Socket, sa))
    -> (ProtocolNumber -> IO (Socket, sa)) -> IO (Socket, sa)
    forall a b. (a -> b) -> a -> b
    $ \listing_fd :: ProtocolNumber
    listing_fd -> do
     Socket
    new_sock <- ProtocolNumber -> Ptr sa -> Int -> IO ProtocolNumber
    forall a sa.
    Integral a =>
    ProtocolNumber -> Ptr sa -> a -> IO ProtocolNumber
    callAccept ProtocolNumber
    listing_fd Ptr sa
    new_sa Int
    sz IO ProtocolNumber -> (ProtocolNumber -> IO Socket) -> IO Socket
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= ProtocolNumber -> IO Socket
    mkSocket
     sa
    new_addr <- Ptr sa -> IO sa
    forall sa. SocketAddress sa => Ptr sa -> IO sa
    peekSocketAddress Ptr sa
    new_sa
     (Socket, sa) -> IO (Socket, 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 :: ProtocolNumber -> Ptr sa -> a -> IO ProtocolNumber
    callAccept fd :: ProtocolNumber
    fd sa :: Ptr sa
    sa sz :: a
    sz = ProtocolNumber
    -> (Ptr ProtocolNumber -> IO ProtocolNumber) -> IO ProtocolNumber
    forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
    with (a -> ProtocolNumber
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral a
    sz) ((Ptr ProtocolNumber -> IO ProtocolNumber) -> IO ProtocolNumber)
    -> (Ptr ProtocolNumber -> IO ProtocolNumber) -> IO ProtocolNumber
    forall a b. (a -> b) -> a -> b
    $ \ ptr_len :: Ptr ProtocolNumber
    ptr_len -> do
    # ifdef HAVE_ADVANCED_SOCKET_FLAGS
           Socket -> String -> IO ProtocolNumber -> IO ProtocolNumber
    forall a. (Eq a, Num a) => Socket -> String -> IO a -> IO a
    throwSocketErrorWaitRead Socket
    listing_sock "Network.Socket.accept"
                            (ProtocolNumber
    -> Ptr sa
    -> Ptr ProtocolNumber
    -> ProtocolNumber
    -> IO ProtocolNumber
    forall sa.
    ProtocolNumber
    -> Ptr sa
    -> Ptr ProtocolNumber
    -> ProtocolNumber
    -> IO ProtocolNumber
    c_accept4 ProtocolNumber
    fd Ptr sa
    sa Ptr ProtocolNumber
    ptr_len (ProtocolNumber
    sockNonBlock ProtocolNumber -> ProtocolNumber -> ProtocolNumber
    forall a. Bits a => a -> a -> a
    .|. ProtocolNumber
    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{-CSockLen???-} -> IO CInt
    foreign import CALLCONV SAFE_ON_WIN "connect"
      c_connect :: CInt -> Ptr sa -> CInt{-CSockLen???-} -> 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{-CSockLen???-} -> CInt -> IO CInt
    #else
    foreign import CALLCONV unsafe "accept"
      c_accept :: CInt -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CInt
    #endif

    #if defined(mingw32_HOST_OS)
    foreign import CALLCONV safe "accept"
      c_accept_safe :: CInt -> Ptr sa -> Ptr CInt{-CSockLen???-} -> 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