    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TupleSections #-}
    {-# OPTIONS_GHC -fno-warn-deprecations #-}

    module Network.Wai.Handler.Warp.Run where

    import Control.Arrow (first)
    import qualified Control.Exception
    import Control.Exception (allowInterrupt)
    import qualified Data.ByteString as S
    import Data.IORef (newIORef, readIORef)
    import Data.Streaming.Network (bindPortTCP)
    import Foreign.C.Error (Errno(..), eCONNABORTED, eMFILE)
    import GHC.IO.Exception (IOException(..), IOErrorType(..))
    import Network.Socket (Socket, close, withSocketsDo, SockAddr, setSocketOption, SocketOption(..))
    #if MIN_VERSION_network(3,1,1)
    import Network.Socket (gracefulClose)
    #endif
    import Network.Socket.BufferPool
    import qualified Network.Socket.ByteString as Sock
    import Network.Wai
    import System.Environment (lookupEnv)
    import System.IO.Error (ioeGetErrorType)
    import qualified System.TimeManager as T
    import System.Timeout (timeout)
    import qualified UnliftIO
    import UnliftIO (toException)

    import Network.Wai.Handler.Warp.Buffer
    import Network.Wai.Handler.Warp.Counter
    import qualified Network.Wai.Handler.Warp.Date as D
    import qualified Network.Wai.Handler.Warp.FdCache as F
    import qualified Network.Wai.Handler.Warp.FileInfoCache as I
    import Network.Wai.Handler.Warp.HTTP1 (http1)
    import Network.Wai.Handler.Warp.HTTP2 (http2)
    import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)
    import Network.Wai.Handler.Warp.Imports hiding (readInt)
    import Network.Wai.Handler.Warp.SendFile
    import Network.Wai.Handler.Warp.Settings
    import Network.Wai.Handler.Warp.Types

    #if WINDOWS
    import Network.Wai.Handler.Warp.Windows
    #else
    import Network.Socket (fdSocket)
    #endif

    -- | Creating 'Connection' for plain HTTP based on a given socket.
    socketConnection :: Settings -> Socket -> IO Connection
    #if MIN_VERSION_network(3,1,1)
    socketConnection :: Settings -> Socket -> IO Connection
    socketConnection Settings
    set Socket
    s = do
    #else
    socketConnection _ s = do
    #endif
        BufferPool
    bufferPool <- Int -> Int -> IO BufferPool
    newBufferPool Int
    2048 Int
    16384
        WriteBuffer
    writeBuffer <- Int -> IO WriteBuffer
    createWriteBuffer Int
    16384
        IORef WriteBuffer
    writeBufferRef <- WriteBuffer -> IO (IORef WriteBuffer)
    forall a. a -> IO (IORef a)
    newIORef WriteBuffer
    writeBuffer
        IORef Bool
    isH2 <- Bool -> IO (IORef Bool)
    forall a. a -> IO (IORef a)
    newIORef Bool
    False -- HTTP/1.x
        Connection -> IO Connection
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Connection {
            connSendMany :: [ByteString] -> IO ()
    connSendMany = Socket -> [ByteString] -> IO ()
    Sock.sendMany Socket
    s
          , connSendAll :: ByteString -> IO ()
    connSendAll = ByteString -> IO ()
    sendall
          , connSendFile :: SendFile
    connSendFile = IORef WriteBuffer -> SendFile
    sendfile IORef WriteBuffer
    writeBufferRef
    #if MIN_VERSION_network(3,1,1)
          , connClose :: IO ()
    connClose = do
                Bool
    h2 <- IORef Bool -> IO Bool
    forall a. IORef a -> IO a
    readIORef IORef Bool
    isH2
                let tm :: Int
    tm = if Bool
    h2 then Settings -> Int
    settingsGracefulCloseTimeout2 Settings
    set
                               else Settings -> Int
    settingsGracefulCloseTimeout1 Settings
    set
                if Int
    tm Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 then
                    Socket -> IO ()
    close Socket
    s
                  else
                    Socket -> Int -> IO ()
    gracefulClose Socket
    s Int
    tm IO () -> (SomeException -> IO ()) -> IO ()
    forall (m :: * -> *) a.
    MonadUnliftIO m =>
    m a -> (SomeException -> m a) -> m a
    `UnliftIO.catchAny` \(UnliftIO.SomeException e
    _) -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    #else
          , connClose = close s
    #endif
          , connRecv :: Recv
    connRecv = Socket -> BufferPool -> Recv
    receive' Socket
    s BufferPool
    bufferPool
          , connRecvBuf :: RecvBuf
    connRecvBuf = \Buffer
    _ Int
    _ -> Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True -- obsoleted
          , connWriteBuffer :: IORef WriteBuffer
    connWriteBuffer = IORef WriteBuffer
    writeBufferRef
          , connHTTP2 :: IORef Bool
    connHTTP2 = IORef Bool
    isH2
          }
      where
        receive' :: Socket -> BufferPool -> Recv
    receive' Socket
    sock BufferPool
    pool = (IOException -> Recv) -> Recv -> Recv
    forall (m :: * -> *) a.
    MonadUnliftIO m =>
    (IOException -> m a) -> m a -> m a
    UnliftIO.handleIO IOException -> Recv
    handler (Recv -> Recv) -> Recv -> Recv
    forall a b. (a -> b) -> a -> b
    $ Socket -> BufferPool -> Recv
    receive Socket
    sock BufferPool
    pool
          where
            handler :: UnliftIO.IOException -> IO ByteString
            handler :: IOException -> Recv
    handler IOException
    e
              | IOException -> IOErrorType
    ioeGetErrorType IOException
    e IOErrorType -> IOErrorType -> Bool
    forall a. Eq a => a -> a -> Bool
    == IOErrorType
    InvalidArgument = ByteString -> Recv
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    ""
              | Bool
    otherwise                            = IOException -> Recv
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    UnliftIO.throwIO IOException
    e

        sendfile :: IORef WriteBuffer -> SendFile
    sendfile IORef WriteBuffer
    writeBufferRef FileId
    fid Integer
    offset Integer
    len IO ()
    hook [ByteString]
    headers = do
          WriteBuffer
    writeBuffer <- IORef WriteBuffer -> IO WriteBuffer
    forall a. IORef a -> IO a
    readIORef IORef WriteBuffer
    writeBufferRef
          Socket -> Buffer -> Int -> (ByteString -> IO ()) -> SendFile
    sendFile Socket
    s (WriteBuffer -> Buffer
    bufBuffer WriteBuffer
    writeBuffer) (WriteBuffer -> Int
    bufSize WriteBuffer
    writeBuffer) ByteString -> IO ()
    sendall
            FileId
    fid Integer
    offset Integer
    len IO ()
    hook [ByteString]
    headers

        sendall :: ByteString -> IO ()
    sendall = Socket -> ByteString -> IO ()
    sendAll' Socket
    s

        sendAll' :: Socket -> ByteString -> IO ()
    sendAll' Socket
    sock ByteString
    bs = (IOException -> Maybe InvalidRequest)
    -> (InvalidRequest -> IO ()) -> IO () -> IO ()
    forall (m :: * -> *) e b a.
    (MonadUnliftIO m, Exception e) =>
    (e -> Maybe b) -> (b -> m a) -> m a -> m a
    UnliftIO.handleJust
          (\ IOException
    e -> if IOException -> IOErrorType
    ioeGetErrorType IOException
    e IOErrorType -> IOErrorType -> Bool
    forall a. Eq a => a -> a -> Bool
    == IOErrorType
    ResourceVanished
            then InvalidRequest -> Maybe InvalidRequest
    forall a. a -> Maybe a
    Just InvalidRequest
    ConnectionClosedByPeer
            else Maybe InvalidRequest
    forall a. Maybe a
    Nothing)
          InvalidRequest -> IO ()
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    UnliftIO.throwIO
          (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Socket -> ByteString -> IO ()
    Sock.sendAll Socket
    sock ByteString
    bs

    -- | Run an 'Application' on the given port.
    -- This calls 'runSettings' with 'defaultSettings'.
    run :: Port -> Application -> IO ()
    run :: Int -> Application -> IO ()
    run Int
    p = Settings -> Application -> IO ()
    runSettings Settings
    defaultSettings { settingsPort :: Int
    settingsPort = Int
    p }

    -- | Run an 'Application' on the port present in the @PORT@
    -- environment variable. Uses the 'Port' given when the variable is unset.
    -- This calls 'runSettings' with 'defaultSettings'.
    --
    -- Since 3.0.9
    runEnv :: Port -> Application -> IO ()
    runEnv :: Int -> Application -> IO ()
    runEnv Int
    p Application
    app = do
        Maybe [Char]
    mp <- [Char] -> IO (Maybe [Char])
    lookupEnv [Char]
    "PORT"

        IO () -> ([Char] -> IO ()) -> Maybe [Char] -> IO ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (Int -> Application -> IO ()
    run Int
    p Application
    app) [Char] -> IO ()
    runReadPort Maybe [Char]
    mp

      where
        runReadPort :: String -> IO ()
        runReadPort :: [Char] -> IO ()
    runReadPort [Char]
    sp = case ReadS Int
    forall a. Read a => ReadS a
    reads [Char]
    sp of
            ((Int
    p', [Char]
    _):[(Int, [Char])]
    _) -> Int -> Application -> IO ()
    run Int
    p' Application
    app
            [(Int, [Char])]
    _ -> [Char] -> IO ()
    forall a. [Char] -> IO a
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
    fail ([Char] -> IO ()) -> [Char] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Invalid value in $PORT: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    sp

    -- | Run an 'Application' with the given 'Settings'.
    -- This opens a listen socket on the port defined in 'Settings' and
    -- calls 'runSettingsSocket'.
    runSettings :: Settings -> Application -> IO ()
    runSettings :: Settings -> Application -> IO ()
    runSettings Settings
    set Application
    app = IO () -> IO ()
    forall a. IO a -> IO a
    withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
        IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
    forall (m :: * -> *) a b c.
    MonadUnliftIO m =>
    m a -> (a -> m b) -> (a -> m c) -> m c
    UnliftIO.bracket
            (Int -> HostPreference -> IO Socket
    bindPortTCP (Settings -> Int
    settingsPort Settings
    set) (Settings -> HostPreference
    settingsHost Settings
    set))
            Socket -> IO ()
    close
            (\Socket
    socket -> do
                Socket -> IO ()
    setSocketCloseOnExec Socket
    socket
                Settings -> Socket -> Application -> IO ()
    runSettingsSocket Settings
    set Socket
    socket Application
    app)

    -- | This installs a shutdown handler for the given socket and
    -- calls 'runSettingsConnection' with the default connection setup action
    -- which handles plain (non-cipher) HTTP.
    -- When the listen socket in the second argument is closed, all live
    -- connections are gracefully shut down.
    --
    -- The supplied socket can be a Unix named socket, which
    -- can be used when reverse HTTP proxying into your application.
    --
    -- Note that the 'settingsPort' will still be passed to 'Application's via the
    -- 'serverPort' record.
    runSettingsSocket :: Settings -> Socket -> Application -> IO ()
    runSettingsSocket :: Settings -> Socket -> Application -> IO ()
    runSettingsSocket set :: Settings
    set@Settings{settingsAccept :: Settings -> Socket -> IO (Socket, SockAddr)
    settingsAccept = Socket -> IO (Socket, SockAddr)
    accept'} Socket
    socket Application
    app = do
        Settings -> IO () -> IO ()
    settingsInstallShutdownHandler Settings
    set IO ()
    closeListenSocket
        Settings -> IO (Connection, SockAddr) -> Application -> IO ()
    runSettingsConnection Settings
    set IO (Connection, SockAddr)
    getConn Application
    app
      where
        getConn :: IO (Connection, SockAddr)
    getConn = do
            (Socket
    s, SockAddr
    sa) <- Socket -> IO (Socket, SockAddr)
    accept' Socket
    socket
            Socket -> IO ()
    setSocketCloseOnExec Socket
    s
            -- NoDelay causes an error for AF_UNIX.
            Socket -> SocketOption -> Int -> IO ()
    setSocketOption Socket
    s SocketOption
    NoDelay Int
    1 IO () -> (SomeException -> IO ()) -> IO ()
    forall (m :: * -> *) a.
    MonadUnliftIO m =>
    m a -> (SomeException -> m a) -> m a
    `UnliftIO.catchAny` \(UnliftIO.SomeException e
    _) -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            Connection
    conn <- Settings -> Socket -> IO Connection
    socketConnection Settings
    set Socket
    s
            (Connection, SockAddr) -> IO (Connection, SockAddr)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Connection
    conn, SockAddr
    sa)

        closeListenSocket :: IO ()
    closeListenSocket = Socket -> IO ()
    close Socket
    socket

    -- | The connection setup action would be expensive. A good example
    -- is initialization of TLS.
    -- So, this converts the connection setup action to the connection maker
    -- which will be executed after forking a new worker thread.
    -- Then this calls 'runSettingsConnectionMaker' with the connection maker.
    -- This allows the expensive computations to be performed
    -- in a separate worker thread instead of the main server loop.
    --
    -- Since 1.3.5
    runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
    runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
    runSettingsConnection Settings
    set IO (Connection, SockAddr)
    getConn Application
    app = Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
    runSettingsConnectionMaker Settings
    set IO (IO Connection, SockAddr)
    getConnMaker Application
    app
      where
        getConnMaker :: IO (IO Connection, SockAddr)
    getConnMaker = do
          (Connection
    conn, SockAddr
    sa) <- IO (Connection, SockAddr)
    getConn
          (IO Connection, SockAddr) -> IO (IO Connection, SockAddr)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Connection -> IO Connection
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Connection
    conn, SockAddr
    sa)

    -- | This modifies the connection maker so that it returns 'TCP' for 'Transport'
    -- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.
    runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
    runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
    runSettingsConnectionMaker Settings
    x IO (IO Connection, SockAddr)
    y =
        Settings
    -> IO (IO (Connection, Transport), SockAddr)
    -> Application
    -> IO ()
    runSettingsConnectionMakerSecure Settings
    x ((IO Connection, SockAddr) -> (IO (Connection, Transport), SockAddr)
    forall {a} {d}. (IO a, d) -> (IO (a, Transport), d)
    toTCP ((IO Connection, SockAddr)
     -> (IO (Connection, Transport), SockAddr))
    -> IO (IO Connection, SockAddr)
    -> IO (IO (Connection, Transport), SockAddr)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO (IO Connection, SockAddr)
    y)
      where
        toTCP :: (IO a, d) -> (IO (a, Transport), d)
    toTCP = (IO a -> IO (a, Transport)) -> (IO a, d) -> (IO (a, Transport), d)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first ((, Transport
    TCP) (a -> (a, Transport)) -> IO a -> IO (a, Transport)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$>)

    ----------------------------------------------------------------

    -- | The core run function which takes 'Settings',
    -- a connection maker and 'Application'.
    -- The connection maker can return a connection of either plain HTTP
    -- or HTTP over TLS.
    --
    -- Since 2.1.4
    runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()
    runSettingsConnectionMakerSecure :: Settings
    -> IO (IO (Connection, Transport), SockAddr)
    -> Application
    -> IO ()
    runSettingsConnectionMakerSecure Settings
    set IO (IO (Connection, Transport), SockAddr)
    getConnMaker Application
    app = do
        Settings -> IO ()
    settingsBeforeMainLoop Settings
    set
        Counter
    counter <- IO Counter
    newCounter
        Settings -> (InternalInfo -> IO ()) -> IO ()
    forall a. Settings -> (InternalInfo -> IO a) -> IO a
    withII Settings
    set ((InternalInfo -> IO ()) -> IO ())
    -> (InternalInfo -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Settings
    -> IO (IO (Connection, Transport), SockAddr)
    -> Application
    -> Counter
    -> InternalInfo
    -> IO ()
    acceptConnection Settings
    set IO (IO (Connection, Transport), SockAddr)
    getConnMaker Application
    app Counter
    counter

    -- | Running an action with internal info.
    --
    -- Since 3.3.11
    withII :: Settings -> (InternalInfo -> IO a) -> IO a
    withII :: forall a. Settings -> (InternalInfo -> IO a) -> IO a
    withII Settings
    set InternalInfo -> IO a
    action =
        (Manager -> IO a) -> IO a
    forall {c}. (Manager -> IO c) -> IO c
    withTimeoutManager ((Manager -> IO a) -> IO a) -> (Manager -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \Manager
    tm ->
        (Recv -> IO a) -> IO a
    forall a. (Recv -> IO a) -> IO a
    D.withDateCache ((Recv -> IO a) -> IO a) -> (Recv -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \Recv
    dc ->
        Int -> (([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
    forall a. Int -> (([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
    F.withFdCache Int
    fdCacheDurationInSeconds ((([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a)
    -> (([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \[Char] -> IO (Maybe Fd, IO ())
    fdc ->
        Int -> (([Char] -> IO FileInfo) -> IO a) -> IO a
    forall a. Int -> (([Char] -> IO FileInfo) -> IO a) -> IO a
    I.withFileInfoCache Int
    fdFileInfoDurationInSeconds ((([Char] -> IO FileInfo) -> IO a) -> IO a)
    -> (([Char] -> IO FileInfo) -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \[Char] -> IO FileInfo
    fic -> do
            let ii :: InternalInfo
    ii = Manager
    -> Recv
    -> ([Char] -> IO (Maybe Fd, IO ()))
    -> ([Char] -> IO FileInfo)
    -> InternalInfo
    InternalInfo Manager
    tm Recv
    dc [Char] -> IO (Maybe Fd, IO ())
    fdc [Char] -> IO FileInfo
    fic
            InternalInfo -> IO a
    action InternalInfo
    ii
      where
        !fdCacheDurationInSeconds :: Int
    fdCacheDurationInSeconds = Settings -> Int
    settingsFdCacheDuration Settings
    set Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    1000000
        !fdFileInfoDurationInSeconds :: Int
    fdFileInfoDurationInSeconds = Settings -> Int
    settingsFileInfoCacheDuration Settings
    set Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    1000000
        !timeoutInSeconds :: Int
    timeoutInSeconds = Settings -> Int
    settingsTimeout Settings
    set Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    1000000
        withTimeoutManager :: (Manager -> IO c) -> IO c
    withTimeoutManager Manager -> IO c
    f = case Settings -> Maybe Manager
    settingsManager Settings
    set of
            Just Manager
    tm -> Manager -> IO c
    f Manager
    tm
            Maybe Manager
    Nothing -> IO Manager -> (Manager -> IO ()) -> (Manager -> IO c) -> IO c
    forall (m :: * -> *) a b c.
    MonadUnliftIO m =>
    m a -> (a -> m b) -> (a -> m c) -> m c
    UnliftIO.bracket
                       (Int -> IO Manager
    T.initialize Int
    timeoutInSeconds)
                       Manager -> IO ()
    T.stopManager
                       Manager -> IO c
    f

    -- Note that there is a thorough discussion of the exception safety of the
    -- following code at: https://github.com/yesodweb/wai/issues/146
    --
    -- We need to make sure of two things:
    --
    -- 1. Asynchronous exceptions are not blocked entirely in the main loop.
    --    Doing so would make it impossible to kill the Warp thread.
    --
    -- 2. Once a connection maker is received via acceptNewConnection, the
    --    connection is guaranteed to be closed, even in the presence of
    --    async exceptions.
    --
    -- Our approach is explained in the comments below.
    acceptConnection :: Settings
                     -> IO (IO (Connection, Transport), SockAddr)
                     -> Application
                     -> Counter
                     -> InternalInfo
                     -> IO ()
    acceptConnection :: Settings
    -> IO (IO (Connection, Transport), SockAddr)
    -> Application
    -> Counter
    -> InternalInfo
    -> IO ()
    acceptConnection Settings
    set IO (IO (Connection, Transport), SockAddr)
    getConnMaker Application
    app Counter
    counter InternalInfo
    ii = do
        -- First mask all exceptions in acceptLoop. This is necessary to
        -- ensure that no async exception is throw between the call to
        -- acceptNewConnection and the registering of connClose.
        --
        -- acceptLoop can be broken by closing the listening socket.
        IO () -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ IO () -> IO ()
    forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
    UnliftIO.mask_ IO ()
    acceptLoop
        -- In some cases, we want to stop Warp here without graceful shutdown.
        -- So, async exceptions are allowed here.
        -- That's why `finally` is not used.
        Settings -> Counter -> IO ()
    gracefulShutdown Settings
    set Counter
    counter
      where
        acceptLoop :: IO ()
    acceptLoop = do
            -- Allow async exceptions before receiving the next connection maker.
            IO ()
    allowInterrupt

            -- acceptNewConnection will try to receive the next incoming
            -- request. It returns a /connection maker/, not a connection,
            -- since in some circumstances creating a working connection
            -- from a raw socket may be an expensive operation, and this
            -- expensive work should not be performed in the main event
            -- loop. An example of something expensive would be TLS
            -- negotiation.
            Maybe (IO (Connection, Transport), SockAddr)
    mx <- IO (Maybe (IO (Connection, Transport), SockAddr))
    acceptNewConnection
            case Maybe (IO (Connection, Transport), SockAddr)
    mx of
                Maybe (IO (Connection, Transport), SockAddr)
    Nothing             -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                Just (IO (Connection, Transport)
    mkConn, SockAddr
    addr) -> do
                    Settings
    -> IO (Connection, Transport)
    -> SockAddr
    -> Application
    -> Counter
    -> InternalInfo
    -> IO ()
    fork Settings
    set IO (Connection, Transport)
    mkConn SockAddr
    addr Application
    app Counter
    counter InternalInfo
    ii
                    IO ()
    acceptLoop

        acceptNewConnection :: IO (Maybe (IO (Connection, Transport), SockAddr))
    acceptNewConnection = do
            Either IOException (IO (Connection, Transport), SockAddr)
    ex <- IO (IO (Connection, Transport), SockAddr)
    -> IO (Either IOException (IO (Connection, Transport), SockAddr))
    forall (m :: * -> *) a.
    MonadUnliftIO m =>
    m a -> m (Either IOException a)
    UnliftIO.tryIO IO (IO (Connection, Transport), SockAddr)
    getConnMaker
            case Either IOException (IO (Connection, Transport), SockAddr)
    ex of
                Right (IO (Connection, Transport), SockAddr)
    x -> Maybe (IO (Connection, Transport), SockAddr)
    -> IO (Maybe (IO (Connection, Transport), SockAddr))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (IO (Connection, Transport), SockAddr)
     -> IO (Maybe (IO (Connection, Transport), SockAddr)))
    -> Maybe (IO (Connection, Transport), SockAddr)
    -> IO (Maybe (IO (Connection, Transport), SockAddr))
    forall a b. (a -> b) -> a -> b
    $ (IO (Connection, Transport), SockAddr)
    -> Maybe (IO (Connection, Transport), SockAddr)
    forall a. a -> Maybe a
    Just (IO (Connection, Transport), SockAddr)
    x
                Left IOException
    e -> do
                    let getErrno :: Errno -> CInt
    getErrno (Errno CInt
    cInt) = CInt
    cInt
                        eConnAborted :: CInt
    eConnAborted = Errno -> CInt
    getErrno Errno
    eCONNABORTED
                        eMfile :: CInt
    eMfile = Errno -> CInt
    getErrno Errno
    eMFILE
                        merrno :: Maybe CInt
    merrno = IOException -> Maybe CInt
    ioe_errno IOException
    e
                    if Maybe CInt
    merrno Maybe CInt -> Maybe CInt -> Bool
    forall a. Eq a => a -> a -> Bool
    == CInt -> Maybe CInt
    forall a. a -> Maybe a
    Just CInt
    eConnAborted Bool -> Bool -> Bool
    || Maybe CInt
    merrno Maybe CInt -> Maybe CInt -> Bool
    forall a. Eq a => a -> a -> Bool
    == CInt -> Maybe CInt
    forall a. a -> Maybe a
    Just CInt
    eMfile
                        then IO (Maybe (IO (Connection, Transport), SockAddr))
    acceptNewConnection
                        else do
                            Settings -> Maybe Request -> SomeException -> IO ()
    settingsOnException Settings
    set Maybe Request
    forall a. Maybe a
    Nothing (SomeException -> IO ()) -> SomeException -> IO ()
    forall a b. (a -> b) -> a -> b
    $ IOException -> SomeException
    forall e. Exception e => e -> SomeException
    toException IOException
    e
                            Maybe (IO (Connection, Transport), SockAddr)
    -> IO (Maybe (IO (Connection, Transport), SockAddr))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (IO (Connection, Transport), SockAddr)
    forall a. Maybe a
    Nothing

    -- Fork a new worker thread for this connection maker, and ask for a
    -- function to unmask (i.e., allow async exceptions to be thrown).
    fork :: Settings
         -> IO (Connection, Transport)
         -> SockAddr
         -> Application
         -> Counter
         -> InternalInfo
         -> IO ()
    fork :: Settings
    -> IO (Connection, Transport)
    -> SockAddr
    -> Application
    -> Counter
    -> InternalInfo
    -> IO ()
    fork Settings
    set IO (Connection, Transport)
    mkConn SockAddr
    addr Application
    app Counter
    counter InternalInfo
    ii = Settings -> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
    settingsFork Settings
    set (((forall a. IO a -> IO a) -> IO ()) -> IO ())
    -> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \forall a. IO a -> IO a
    unmask ->
        -- Call the user-supplied on exception code if any
        -- exceptions are thrown.
        --
        -- Intentionally using Control.Exception.handle, since we want to
        -- catch all exceptions and avoid them from propagating, even
        -- async exceptions. See:
        -- https://github.com/yesodweb/wai/issues/850
        (SomeException -> IO ()) -> IO () -> IO ()
    forall e a. Exception e => (e -> IO a) -> IO a -> IO a
    Control.Exception.handle (Settings -> Maybe Request -> SomeException -> IO ()
    settingsOnException Settings
    set Maybe Request
    forall a. Maybe a
    Nothing) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            -- Run the connection maker to get a new connection, and ensure
            -- that the connection is closed. If the mkConn call throws an
            -- exception, we will leak the connection. If the mkConn call is
            -- vulnerable to attacks (e.g., Slowloris), we do nothing to
            -- protect the server. It is therefore vital that mkConn is well
            -- vetted.
            --
            -- We grab the connection before registering timeouts since the
            -- timeouts will be useless during connection creation, due to the
            -- fact that async exceptions are still masked.
            IO (Connection, Transport)
    -> ((Connection, Transport) -> IO ())
    -> ((Connection, Transport) -> IO ())
    -> IO ()
    forall (m :: * -> *) a b c.
    MonadUnliftIO m =>
    m a -> (a -> m b) -> (a -> m c) -> m c
    UnliftIO.bracket IO (Connection, Transport)
    mkConn (Connection, Transport) -> IO ()
    forall {b}. (Connection, b) -> IO ()
    cleanUp ((IO () -> IO ()) -> (Connection, Transport) -> IO ()
    forall {c}. (IO () -> IO c) -> (Connection, Transport) -> IO c
    serve IO () -> IO ()
    forall a. IO a -> IO a
    unmask)
      where
        cleanUp :: (Connection, b) -> IO ()
    cleanUp (Connection
    conn, b
    _) = Connection -> IO ()
    connClose Connection
    conn IO () -> IO () -> IO ()
    forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
    `UnliftIO.finally` do
                              WriteBuffer
    writeBuffer <- IORef WriteBuffer -> IO WriteBuffer
    forall a. IORef a -> IO a
    readIORef (IORef WriteBuffer -> IO WriteBuffer)
    -> IORef WriteBuffer -> IO WriteBuffer
    forall a b. (a -> b) -> a -> b
    $ Connection -> IORef WriteBuffer
    connWriteBuffer Connection
    conn
                              WriteBuffer -> IO ()
    bufFree WriteBuffer
    writeBuffer

        -- We need to register a timeout handler for this thread, and
        -- cancel that handler as soon as we exit.
        serve :: (IO () -> IO c) -> (Connection, Transport) -> IO c
    serve IO () -> IO c
    unmask (Connection
    conn, Transport
    transport) = IO Handle -> (Handle -> IO ()) -> (Handle -> IO c) -> IO c
    forall (m :: * -> *) a b c.
    MonadUnliftIO m =>
    m a -> (a -> m b) -> (a -> m c) -> m c
    UnliftIO.bracket IO Handle
    register Handle -> IO ()
    cancel ((Handle -> IO c) -> IO c) -> (Handle -> IO c) -> IO c
    forall a b. (a -> b) -> a -> b
    $ \Handle
    th -> do
            -- We now have fully registered a connection close handler in
            -- the case of all exceptions, so it is safe to once again
            -- allow async exceptions.
            IO () -> IO c
    unmask (IO () -> IO c)
    -> ((Bool -> IO ()) -> IO ()) -> (Bool -> IO ()) -> IO c
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
                -- Call the user-supplied code for connection open and
                -- close events
               IO Bool -> (Bool -> IO ()) -> (Bool -> IO ()) -> IO ()
    forall (m :: * -> *) a b c.
    MonadUnliftIO m =>
    m a -> (a -> m b) -> (a -> m c) -> m c
    UnliftIO.bracket (SockAddr -> IO Bool
    onOpen SockAddr
    addr) (SockAddr -> Bool -> IO ()
    forall {p}. SockAddr -> p -> IO ()
    onClose SockAddr
    addr) ((Bool -> IO ()) -> IO c) -> (Bool -> IO ()) -> IO c
    forall a b. (a -> b) -> a -> b
    $ \Bool
    goingon ->
               -- Actually serve this connection.  bracket with closeConn
               -- above ensures the connection is closed.
               Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    goingon (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Connection
    -> InternalInfo
    -> Handle
    -> SockAddr
    -> Transport
    -> Settings
    -> Application
    -> IO ()
    serveConnection Connection
    conn InternalInfo
    ii Handle
    th SockAddr
    addr Transport
    transport Settings
    set Application
    app
          where
            register :: IO Handle
    register = Manager -> IO () -> IO Handle
    T.registerKillThread (InternalInfo -> Manager
    timeoutManager InternalInfo
    ii) (Connection -> IO ()
    connClose Connection
    conn)
            cancel :: Handle -> IO ()
    cancel   = Handle -> IO ()
    T.cancel

        onOpen :: SockAddr -> IO Bool
    onOpen SockAddr
    adr    = Counter -> IO ()
    increase Counter
    counter IO () -> IO Bool -> IO Bool
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Settings -> SockAddr -> IO Bool
    settingsOnOpen  Settings
    set SockAddr
    adr
        onClose :: SockAddr -> p -> IO ()
    onClose SockAddr
    adr p
    _ = Counter -> IO ()
    decrease Counter
    counter IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Settings -> SockAddr -> IO ()
    settingsOnClose Settings
    set SockAddr
    adr

    serveConnection :: Connection
                    -> InternalInfo
                    -> T.Handle
                    -> SockAddr
                    -> Transport
                    -> Settings
                    -> Application
                    -> IO ()
    serveConnection :: Connection
    -> InternalInfo
    -> Handle
    -> SockAddr
    -> Transport
    -> Settings
    -> Application
    -> IO ()
    serveConnection Connection
    conn InternalInfo
    ii Handle
    th SockAddr
    origAddr Transport
    transport Settings
    settings Application
    app = do
        -- fixme: Upgrading to HTTP/2 should be supported.
        (Bool
    h2,ByteString
    bs) <- if Transport -> Bool
    isHTTP2 Transport
    transport then
                       (Bool, ByteString) -> IO (Bool, ByteString)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, ByteString
    "")
                     else do
                       ByteString
    bs0 <- Connection -> Recv
    connRecv Connection
    conn
                       if ByteString -> Int
    S.length ByteString
    bs0 Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    4 Bool -> Bool -> Bool
    && ByteString
    "PRI " ByteString -> ByteString -> Bool
    `S.isPrefixOf` ByteString
    bs0 then
                           (Bool, ByteString) -> IO (Bool, ByteString)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, ByteString
    bs0)
                         else
                           (Bool, ByteString) -> IO (Bool, ByteString)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, ByteString
    bs0)
        if Settings -> Bool
    settingsHTTP2Enabled Settings
    settings Bool -> Bool -> Bool
    && Bool
    h2 then do
            Settings
    -> InternalInfo
    -> Connection
    -> Transport
    -> Application
    -> SockAddr
    -> Handle
    -> ByteString
    -> IO ()
    http2 Settings
    settings InternalInfo
    ii Connection
    conn Transport
    transport Application
    app SockAddr
    origAddr Handle
    th ByteString
    bs
          else do
            Settings
    -> InternalInfo
    -> Connection
    -> Transport
    -> Application
    -> SockAddr
    -> Handle
    -> ByteString
    -> IO ()
    http1 Settings
    settings InternalInfo
    ii Connection
    conn Transport
    transport Application
    app SockAddr
    origAddr Handle
    th ByteString
    bs

    -- | Set flag FileCloseOnExec flag on a socket (on Unix)
    --
    -- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs
    --
    -- @since 3.2.17
    setSocketCloseOnExec :: Socket -> IO ()
    #if WINDOWS
    setSocketCloseOnExec _ = return ()
    #else
    setSocketCloseOnExec :: Socket -> IO ()
    setSocketCloseOnExec Socket
    socket = do
    #if MIN_VERSION_network(3,0,0)
        CInt
    fd <- Socket -> IO CInt
    fdSocket Socket
    socket
    #else
        let fd = fdSocket socket
    #endif
        Fd -> IO ()
    F.setFileCloseOnExec (Fd -> IO ()) -> Fd -> IO ()
    forall a b. (a -> b) -> a -> b
    $ CInt -> Fd
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral CInt
    fd
    #endif

    gracefulShutdown :: Settings -> Counter -> IO ()
    gracefulShutdown :: Settings -> Counter -> IO ()
    gracefulShutdown Settings
    set Counter
    counter =
        case Settings -> Maybe Int
    settingsGracefulShutdownTimeout Settings
    set of
            Maybe Int
    Nothing ->
                Counter -> IO ()
    waitForZero Counter
    counter
            (Just Int
    seconds) ->
                IO (Maybe ()) -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (Int -> IO () -> IO (Maybe ())
    forall a. Int -> IO a -> IO (Maybe a)
    timeout (Int
    seconds Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    microsPerSecond) (Counter -> IO ()
    waitForZero Counter
    counter))
                where microsPerSecond :: Int
    microsPerSecond = Int
    1000000