{-# LANGUAGE CPP #-}

#include "HsNetDef.h"

-- | Blocking socket operations which a caller can give up on.
--
--   Each takes an 'STM' action beside the operation.  Whichever
--   settles first decides the result: 'Left' when the caller gave up,
--   'Right' when the operation completed.  Nothing has to be closed or
--   interrupted to make the thread return, so neither the delivery of
--   @evtClose@ by @closeFdWith@ nor an asynchronous exception reaching
--   a blocking call is relied upon.
--
--   __On Windows these need the threaded runtime.__  There is no
--   readiness to wait for there, so the operation is started and then
--   cancelled, and the thread it runs in blocks in a foreign call.
--   Without @-threaded@ that blocks every other thread too, including
--   the one which would have given up, and nothing returns at all.
module Network.Socket.Wait (
    withReadable,
    acceptWith,
    recvBufWith,
    recvBufFromWith,
    isClosedSocketError,
    isTransientAcceptError,
) where

import Control.Concurrent.STM
import qualified Control.Exception as E
import Foreign.C.Error (
    Errno (..),
    eCONNABORTED,
    eHOSTDOWN,
    eHOSTUNREACH,
    eNETDOWN,
    eNETUNREACH,
    eNONET,
    eNOPROTOOPT,
    ePROTO,
 )
import GHC.IO.Exception (IOErrorType (..), ioe_errno)
import System.IO.Error (ioeGetErrorType)

import Network.Socket.Buffer
#if defined(mingw32_HOST_OS)
import Network.Socket.Cbits
import Network.Socket.Win32.Cancel
#else
import Network.Socket.STM
#endif
import Network.Socket.Imports
import Network.Socket.Syscall
import Network.Socket.Types

-- | Running an action once the socket is readable, unless the 'STM'
--   action fires first.  The 'STM' action is also looked at before
--   anything else, so a caller which has already given up never waits.
--   An operation which has completed wins a tie, so nothing it has
--   already received is thrown away.
--
--   __The action must be an operation on this socket which returns
--   without blocking once the socket is readable.__  The type does not
--   say so and nothing checks it.  On POSIX the action runs on the
--   calling thread after readiness and nothing interrupts it there: the
--   give-up ends the wait, not the action.  On Windows there is no
--   readiness to wait for, so the action is started at once on a thread
--   of its own and the give-up cancels it with @CancelIoEx@ on this
--   socket, which reaches nothing else -- an action blocked on anything
--   else would never end.
--
--   __One reader at a time__ is what keeps that condition.  A second
--   thread taking the data between the readiness and the action leaves
--   the action blocking on the socket, with the give-up no longer in
--   play.
--
--   __The 'STM' action is run more than once__, so it has to be a test
--   and not something which takes what it reads: it is looked at before
--   the wait and again as part of it, and 'Network.Socket.ByteString.recvWith'
--   looks at it once more before a read which would not block.  Reading
--   a 'TVar' is what it is for.
withReadable :: Socket -> STM a -> IO b -> IO (Either a b)
withReadable :: forall a b. Socket -> STM a -> IO b -> IO (Either a b)
withReadable Socket
s STM a
giveUp IO b
act = do
    -- Looking at the give-up first: on Windows 'wait' starts the
    -- operation before it looks at any STM, and on POSIX this keeps a
    -- caller which has given up off a descriptor close may have freed.
    Maybe a
gaveUp <- STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (STM (Maybe a) -> IO (Maybe a)) -> STM (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> STM a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM a
giveUp) STM (Maybe a) -> STM (Maybe a) -> STM (Maybe a)
forall a. STM a -> STM a -> STM a
`orElse` Maybe a -> STM (Maybe a)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    case Maybe a
gaveUp of
        Just a
a -> Either a b -> IO (Either a b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a b -> IO (Either a b)) -> Either a b -> IO (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
a
        Maybe a
Nothing -> IO (Either a b)
wait
  where
#if !defined(mingw32_HOST_OS)
    wait :: IO (Either a b)
wait = do
        (STM ()
readable, IO ()
cancelWait) <- Socket -> IO (STM (), IO ())
waitAndCancelReadSocketSTM Socket
s
        Either a ()
ev <-
            STM (Either a ()) -> IO (Either a ())
forall a. STM a -> IO a
atomically ((a -> Either a ()
forall a b. a -> Either a b
Left (a -> Either a ()) -> STM a -> STM (Either a ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM a
giveUp) STM (Either a ()) -> STM (Either a ()) -> STM (Either a ())
forall a. STM a -> STM a -> STM a
`orElse` (() -> Either a ()
forall a b. b -> Either a b
Right (() -> Either a ()) -> STM () -> STM (Either a ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM ()
readable))
                IO (Either a ()) -> IO () -> IO (Either a ())
forall a b. IO a -> IO b -> IO a
`E.finally` (IO ()
cancelWait IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` IOException -> IO ()
gone)
        (a -> IO (Either a b))
-> (() -> IO (Either a b)) -> Either a () -> IO (Either a b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either a b -> IO (Either a b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a b -> IO (Either a b))
-> (a -> Either a b) -> a -> IO (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left) (IO (Either a b) -> () -> IO (Either a b)
forall a b. a -> b -> a
const (IO (Either a b) -> () -> IO (Either a b))
-> IO (Either a b) -> () -> IO (Either a b)
forall a b. (a -> b) -> a -> b
$ b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> IO b -> IO (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO b
act) Either a ()
ev

    -- The cancel can throw, and from a finally that would replace the
    -- exception which ended the wait -- the timeout the caller is waiting
    -- to see, say.  What it reports is a registration which has already
    -- gone, and there is nothing to do about that.
    gone :: E.IOException -> IO ()
    gone :: IOException -> IO ()
gone IOException
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
    wait = do
        (completed, cancelAct) <- windowsViaSTM s act
        -- The operation wins a tie.  It has already read into the
        -- caller's buffer by then, and answering Left would throw those
        -- bytes away -- which for a stream loses them for good.
        --
        -- onException because the call runs in a thread of its own here:
        -- an asynchronous exception arriving during the wait would
        -- otherwise leave it blocked in a foreign call, holding the
        -- socket and writing into a buffer the caller has let go of.
        ev <-
            atomically ((Right <$> completed) `orElse` (Left <$> giveUp))
                `E.onException` cancelAct
        case ev of
            Right b -> return $ Right b
            Left a -> do
                cancelAct
                return $ Left a
#endif

-- | 'accept' which the caller can give up on.
--
--   @since 3.2.10.0
acceptWith :: SocketAddress sa => Socket -> STM a -> IO (Either a (Socket, sa))
acceptWith :: forall sa a.
SocketAddress sa =>
Socket -> STM a -> IO (Either a (Socket, sa))
acceptWith Socket
s STM a
giveUp = Socket -> STM a -> IO (Socket, sa) -> IO (Either a (Socket, sa))
forall a b. Socket -> STM a -> IO b -> IO (Either a b)
withReadable Socket
s STM a
giveUp (IO (Socket, sa) -> IO (Either a (Socket, sa)))
-> IO (Socket, sa) -> IO (Either a (Socket, sa))
forall a b. (a -> b) -> a -> b
$ Socket -> IO (Socket, sa)
forall sa. SocketAddress sa => Socket -> IO (Socket, sa)
accept Socket
s

-- | 'recvBuf' which the caller can give up on.
--
--   @since 3.2.10.0
recvBufWith :: Socket -> Ptr Word8 -> Int -> STM a -> IO (Either a Int)
recvBufWith :: forall a. Socket -> Ptr Word8 -> Int -> STM a -> IO (Either a Int)
recvBufWith Socket
s Ptr Word8
ptr Int
nbytes STM a
giveUp = Socket -> STM a -> IO Int -> IO (Either a Int)
forall a b. Socket -> STM a -> IO b -> IO (Either a b)
withReadable Socket
s STM a
giveUp (IO Int -> IO (Either a Int)) -> IO Int -> IO (Either a Int)
forall a b. (a -> b) -> a -> b
$ Socket -> Ptr Word8 -> Int -> IO Int
recvBuf Socket
s Ptr Word8
ptr Int
nbytes

-- | 'recvBufFrom' which the caller can give up on.
--
--   @since 3.2.10.0
recvBufFromWith
    :: SocketAddress sa
    => Socket -> Ptr Word8 -> Int -> STM a -> IO (Either a (Int, sa))
recvBufFromWith :: forall sa a.
SocketAddress sa =>
Socket -> Ptr Word8 -> Int -> STM a -> IO (Either a (Int, sa))
recvBufFromWith Socket
s Ptr Word8
ptr Int
nbytes STM a
giveUp =
    Socket -> STM a -> IO (Int, sa) -> IO (Either a (Int, sa))
forall a b. Socket -> STM a -> IO b -> IO (Either a b)
withReadable Socket
s STM a
giveUp (IO (Int, sa) -> IO (Either a (Int, sa)))
-> IO (Int, sa) -> IO (Either a (Int, sa))
forall a b. (a -> b) -> a -> b
$ Socket -> Ptr Word8 -> Int -> IO (Int, sa)
forall sa a.
SocketAddress sa =>
Socket -> Ptr a -> Int -> IO (Int, sa)
recvBufFrom Socket
s Ptr Word8
ptr Int
nbytes

-- | Whether this is the error a socket operation gives once the socket has
--   been closed under it.
--
--   A caller which stops when it is told also stops when the socket it was
--   waiting on goes away, and this is how that arrives.  It is not an
--   error to report: closing the socket is how a server was stopped
--   before there was anything to tell it, and callers which do that are
--   still out there.
--
--   @since 3.2.10.0
isClosedSocketError :: E.IOException -> Bool
isClosedSocketError :: IOException -> Bool
isClosedSocketError IOException
e = IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
InvalidArgument Bool -> Bool -> Bool
|| IOException -> Bool
forall {p}. p -> Bool
isWinsock IOException
e
  where
#if defined(mingw32_HOST_OS)
    -- closesocket gives WSAEINTR to a call already blocked on the socket
    -- and WSAENOTSOCK to one which starts afterwards.
    isWinsock x = ioe_errno x `elem` map Just [wsaEINTR, wsaENOTSOCK]
#else
    isWinsock :: p -> Bool
isWinsock p
_ = Bool
False
#endif

-- | Whether an exception from 'accept' is about the connection it was
--   accepting rather than about the listening socket.
--
--   The peer may reset the connection before it is accepted
--   (@ECONNABORTED@), and Linux reports a new socket's already-pending
--   network errors through @accept()@ as well; accept(2) asks for all of
--   these to be retried, like @EAGAIN@.  The connection has left the queue
--   by then, so a retry blocks for a new one rather than spinning on the
--   same failure.
--
--   Two which are not here:
--
--   * Running out of descriptors (@EMFILE@, @ENFILE@) is about the process,
--     not about one connection, and retrying at once spins: the listening
--     socket stays readable.  'System.IO.Error.isFullError' names it, and a
--     caller which retries it should wait first.
--
--   * @EOPNOTSUPP@ is on accept(2)'s list and is left off this one on
--     purpose: it is also what a listening socket which is not
--     'Network.Socket.Stream' answers, which is permanent, and a retry
--     would spin on it forever.
--
--   Winsock numbers its errors apart from @errno@, so on Windows a list
--   of its own is read as well.  @WSAEINTR@ is not on it: there it is
--   what @closesocket@ gives a blocked call, which 'isClosedSocketError'
--   takes.  @WSAENOBUFS@ is left off for the reason @EMFILE@ is.
--
--   @since 3.2.10.0
isTransientAcceptError :: E.IOException -> Bool
isTransientAcceptError :: IOException -> Bool
isTransientAcceptError IOException
e =
    IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
Interrupted Bool -> Bool -> Bool
|| (Errno -> Bool) -> [Errno] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Errno -> Bool
is [Errno]
errnos Bool -> Bool -> Bool
|| IOException -> Bool
forall {p}. p -> Bool
isWinsock IOException
e
  where
    -- An errno the platform does not have is Errno (-1), which would
    -- otherwise match every error carrying that.
    is :: Errno -> Bool
is (Errno CInt
n) = CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= -CInt
1 Bool -> Bool -> Bool
&& IOException -> Maybe CInt
ioe_errno IOException
e Maybe CInt -> Maybe CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> Maybe CInt
forall a. a -> Maybe a
Just CInt
n
    errnos :: [Errno]
errnos =
        [ Errno
eCONNABORTED
        , Errno
eHOSTDOWN
        , Errno
eHOSTUNREACH
        , Errno
eNETDOWN
        , Errno
eNETUNREACH
        , Errno
eNONET
        , Errno
eNOPROTOOPT
        , Errno
ePROTO
        ]
#if defined(mingw32_HOST_OS)
    isWinsock x = ioe_errno x `elem` map Just codes
    codes =
        [ wsaECONNABORTED
        , wsaECONNRESET
        , wsaEHOSTDOWN
        , wsaEHOSTUNREACH
        , wsaENETDOWN
        , wsaENETRESET
        , wsaENETUNREACH
        , wsaENOPROTOOPT
        ]
#else
    isWinsock :: p -> Bool
isWinsock p
_ = Bool
False
#endif