    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE PackageImports #-}
    {-# LANGUAGE PatternGuards #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TupleSections #-}
    {-# LANGUAGE ViewPatterns #-}
    {-# OPTIONS_GHC -fno-warn-deprecations #-}

    module Network.Wai.Handler.Warp.Run where

    import "iproute" Data.IP (toHostAddress, toHostAddress6)
    import Control.Arrow (first)
    import qualified Control.Concurrent as Conc (yield)
    import Control.Exception as E
    import qualified Data.ByteString as S
    import Data.Char (chr)
    import Data.IORef (IORef, newIORef, readIORef, writeIORef)
    import Data.Streaming.Network (bindPortTCP)
    import Foreign.C.Error (Errno(..), eCONNABORTED)
    import GHC.IO.Exception (IOException(..), IOErrorType(..))
    import qualified Network.HTTP2 as H2
    import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))
    #if MIN_VERSION_network(3,1,1)
    import Network.Socket (gracefulClose)
    #endif
    import qualified Network.Socket.ByteString as Sock
    import Network.Wai
    import Network.Wai.Internal (ResponseReceived (ResponseReceived))
    import System.Environment (lookupEnv)
    import System.IO.Error (ioeGetErrorType)
    import qualified System.TimeManager as T
    import System.Timeout (timeout)

    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.HTTP2 (http2)
    import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)
    import Network.Wai.Handler.Warp.Header
    import Network.Wai.Handler.Warp.Imports hiding (readInt)
    import Network.Wai.Handler.Warp.ReadInt
    import Network.Wai.Handler.Warp.Recv
    import Network.Wai.Handler.Warp.Request
    import Network.Wai.Handler.Warp.Response
    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 set :: Settings
    set s :: Socket
    s = do
    #else
    socketConnection _ s = do
    #endif
        BufferPool
    bufferPool <- IO BufferPool
    newBufferPool
        Buffer
    writeBuf <- Int -> IO Buffer
    allocateBuffer Int
    bufferSize
        let sendall :: ByteString -> IO ()
    sendall = Socket -> ByteString -> IO ()
    sendAll' Socket
    s
        IORef Bool
    isH2 <- Bool -> IO (IORef Bool)
    forall a. a -> IO (IORef a)
    newIORef Bool
    False -- HTTP/1.x
        Connection -> IO Connection
    forall (m :: * -> *) a. Monad m => a -> m a
    return $WConnection :: ([ByteString] -> IO ())
    -> (ByteString -> IO ())
    -> SendFile
    -> IO ()
    -> IO ()
    -> Recv
    -> RecvBuf
    -> Buffer
    -> Int
    -> IORef Bool
    -> Connection
    Connection {
            connSendMany :: [ByteString] -> IO ()
    connSendMany = Socket -> [ByteString] -> IO ()
    Sock.sendMany Socket
    s
          , connSendAll :: ByteString -> IO ()
    connSendAll = ByteString -> IO ()
    sendall
          , connSendFile :: SendFile
    connSendFile = Socket -> Buffer -> Int -> (ByteString -> IO ()) -> SendFile
    sendFile Socket
    s Buffer
    writeBuf Int
    bufferSize ByteString -> IO ()
    sendall
    #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
    == 0 then
                    Socket -> IO ()
    close Socket
    s
                  else
                    Socket -> Int -> IO ()
    gracefulClose Socket
    s Int
    tm IO () -> (SomeException -> IO ()) -> IO ()
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `E.catch` \(E.SomeException _) -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    #else
          , connClose = close s
    #endif
          , connFree :: IO ()
    connFree = Buffer -> IO ()
    freeBuffer Buffer
    writeBuf
          , connRecv :: Recv
    connRecv = Socket -> BufferPool -> Recv
    receive Socket
    s BufferPool
    bufferPool
          , connRecvBuf :: RecvBuf
    connRecvBuf = Socket -> RecvBuf
    receiveBuf Socket
    s
          , connWriteBuffer :: Buffer
    connWriteBuffer = Buffer
    writeBuf
          , connBufferSize :: Int
    connBufferSize = Int
    bufferSize
          , connHTTP2 :: IORef Bool
    connHTTP2 = IORef Bool
    isH2
          }
      where
        sendAll' :: Socket -> ByteString -> IO ()
    sendAll' sock :: Socket
    sock bs :: ByteString
    bs = (IOError -> Maybe InvalidRequest)
    -> (InvalidRequest -> IO ()) -> IO () -> IO ()
    forall e b a.
    Exception e =>
    (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
    E.handleJust
          (\ e :: IOError
    e -> if IOError -> IOErrorType
    ioeGetErrorType IOError
    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 e a. Exception e => e -> IO a
    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 p :: 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 p :: Int
    p app :: Application
    app = do
        Maybe String
    mp <- String -> IO (Maybe String)
    lookupEnv "PORT"

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

      where
        runReadPort :: String -> IO ()
        runReadPort :: String -> IO ()
    runReadPort sp :: String
    sp = case ReadS Int
    forall a. Read a => ReadS a
    reads String
    sp of
            ((p' :: Int
    p', _):_) -> Int -> Application -> IO ()
    run Int
    p' Application
    app
            _ -> String -> IO ()
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "Invalid value in $PORT: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    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 set :: Settings
    set app :: 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 a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket
            (Int -> HostPreference -> IO Socket
    bindPortTCP (Settings -> Int
    settingsPort Settings
    set) (Settings -> HostPreference
    settingsHost Settings
    set))
            Socket -> IO ()
    close
            (\socket :: 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 socket :: Socket
    socket app :: 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
    #if WINDOWS
            (s, sa) <- windowsThreadBlockHack $ accept socket
    #else
            (s :: Socket
    s, sa :: SockAddr
    sa) <- Socket -> IO (Socket, SockAddr)
    accept Socket
    socket
    #endif
            Socket -> IO ()
    setSocketCloseOnExec Socket
    s
            -- NoDelay causes an error for AF_UNIX.
            Socket -> SocketOption -> Int -> IO ()
    setSocketOption Socket
    s SocketOption
    NoDelay 1 IO () -> (SomeException -> IO ()) -> IO ()
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `E.catch` \(E.SomeException _) -> () -> IO ()
    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 (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 set :: Settings
    set getConn :: IO (Connection, SockAddr)
    getConn app :: 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
          (conn :: Connection
    conn, sa :: SockAddr
    sa) <- IO (Connection, SockAddr)
    getConn
          (IO Connection, SockAddr) -> IO (IO Connection, SockAddr)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Connection -> IO Connection
    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 x :: Settings
    x y :: IO (IO Connection, SockAddr)
    y =
        Settings
    -> IO (IO (Connection, Transport), SockAddr)
    -> Application
    -> IO ()
    runSettingsConnectionMakerSecure Settings
    x ((IO Connection, SockAddr) -> (IO (Connection, Transport), SockAddr)
    forall t d. (IO t, d) -> (IO (t, 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 t, d) -> (IO (t, Transport), d)
    toTCP = (IO t -> IO (t, Transport)) -> (IO t, d) -> (IO (t, Transport), d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first ((, Transport
    TCP) (t -> (t, Transport)) -> IO t -> IO (t, 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 set :: Settings
    set getConnMaker :: IO (IO (Connection, Transport), SockAddr)
    getConnMaker app :: 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 :: Settings -> (InternalInfo -> IO a) -> IO a
    withII set :: Settings
    set action :: 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
    $ \tm :: 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
    $ \dc :: Recv
    dc ->
        Int -> ((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
    forall a. Int -> ((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
    F.withFdCache Int
    fdCacheDurationInSeconds (((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a)
    -> ((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \fdc :: String -> IO (Maybe Fd, IO ())
    fdc ->
        Int -> ((String -> IO FileInfo) -> IO a) -> IO a
    forall a. Int -> ((String -> IO FileInfo) -> IO a) -> IO a
    I.withFileInfoCache Int
    fdFileInfoDurationInSeconds (((String -> IO FileInfo) -> IO a) -> IO a)
    -> ((String -> IO FileInfo) -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \fic :: String -> IO FileInfo
    fic -> do
            let ii :: InternalInfo
    ii = Manager
    -> Recv
    -> (String -> IO (Maybe Fd, IO ()))
    -> (String -> IO FileInfo)
    -> InternalInfo
    InternalInfo Manager
    tm Recv
    dc String -> IO (Maybe Fd, IO ())
    fdc String -> 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
    * 1000000
        !fdFileInfoDurationInSeconds :: Int
    fdFileInfoDurationInSeconds = Settings -> Int
    settingsFileInfoCacheDuration Settings
    set Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * 1000000
        !timeoutInSeconds :: Int
    timeoutInSeconds = Settings -> Int
    settingsTimeout Settings
    set Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * 1000000
        withTimeoutManager :: (Manager -> IO c) -> IO c
    withTimeoutManager f :: Manager -> IO c
    f = case Settings -> Maybe Manager
    settingsManager Settings
    set of
            Just tm :: Manager
    tm -> Manager -> IO c
    f Manager
    tm
            Nothing -> IO Manager -> (Manager -> IO ()) -> (Manager -> IO c) -> IO c
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    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 set :: Settings
    set getConnMaker :: IO (IO (Connection, Transport), SockAddr)
    getConnMaker app :: Application
    app counter :: Counter
    counter ii :: 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 listing 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 a. IO a -> IO a
    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
                Nothing             -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                Just (mkConn :: IO (Connection, Transport)
    mkConn, addr :: 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 IOError (IO (Connection, Transport), SockAddr)
    ex <- IO (IO (Connection, Transport), SockAddr)
    -> IO (Either IOError (IO (Connection, Transport), SockAddr))
    forall e a. Exception e => IO a -> IO (Either e a)
    try IO (IO (Connection, Transport), SockAddr)
    getConnMaker
            case Either IOError (IO (Connection, Transport), SockAddr)
    ex of
                Right x :: (IO (Connection, Transport), SockAddr)
    x -> Maybe (IO (Connection, Transport), SockAddr)
    -> IO (Maybe (IO (Connection, Transport), SockAddr))
    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 e :: IOError
    e -> do
                    let eConnAborted :: CInt
    eConnAborted = Errno -> CInt
    getErrno Errno
    eCONNABORTED
                        getErrno :: Errno -> CInt
    getErrno (Errno cInt :: CInt
    cInt) = CInt
    cInt
                    if IOError -> Maybe CInt
    ioe_errno IOError
    e Maybe CInt -> Maybe CInt -> Bool
    forall a. Eq a => a -> a -> Bool
    == CInt -> Maybe CInt
    forall a. a -> Maybe a
    Just CInt
    eConnAborted
                        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
    $ IOError -> SomeException
    forall e. Exception e => e -> SomeException
    toException IOError
    e
                            Maybe (IO (Connection, Transport), SockAddr)
    -> IO (Maybe (IO (Connection, Transport), SockAddr))
    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 set :: Settings
    set mkConn :: IO (Connection, Transport)
    mkConn addr :: SockAddr
    addr app :: Application
    app counter :: Counter
    counter ii :: 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
    $ \unmask :: forall a. IO a -> IO a
    unmask ->
        -- Call the user-supplied on exception code if any
        -- exceptions are thrown.
        (SomeException -> IO ()) -> IO () -> IO ()
    forall e a. Exception e => (e -> IO a) -> IO a -> IO a
    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 a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    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 (conn :: Connection
    conn, _) = Connection -> IO ()
    connClose Connection
    conn IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO a
    `finally` Connection -> IO ()
    connFree Connection
    conn

        -- 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 unmask :: IO () -> IO c
    unmask (conn :: Connection
    conn, transport :: Transport
    transport) = IO Handle -> (Handle -> IO ()) -> (Handle -> IO c) -> IO c
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket IO Handle
    register Handle -> IO ()
    cancel ((Handle -> IO c) -> IO c) -> (Handle -> IO c) -> IO c
    forall a b. (a -> b) -> a -> b
    $ \th :: 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 a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    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
    $ \goingon :: 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 adr :: SockAddr
    adr    = Counter -> IO ()
    increase Counter
    counter IO () -> IO Bool -> IO Bool
    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 adr :: SockAddr
    adr _ = Counter -> IO ()
    decrease Counter
    counter IO () -> IO () -> IO ()
    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 conn :: Connection
    conn ii :: InternalInfo
    ii th :: Handle
    th origAddr :: SockAddr
    origAddr transport :: Transport
    transport settings :: Settings
    settings app :: Application
    app = do
        -- fixme: Upgrading to HTTP/2 should be supported.
        (h2 :: Bool
    h2,bs :: ByteString
    bs) <- if Transport -> Bool
    isHTTP2 Transport
    transport then
                       (Bool, ByteString) -> IO (Bool, ByteString)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, "")
                     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
    >= 4 Bool -> Bool -> Bool
    && "PRI " ByteString -> ByteString -> Bool
    `S.isPrefixOf` ByteString
    bs0 then
                           (Bool, ByteString) -> IO (Bool, ByteString)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, ByteString
    bs0)
                         else
                           (Bool, ByteString) -> IO (Bool, ByteString)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, ByteString
    bs0)
        IORef Bool
    istatus <- Bool -> IO (IORef Bool)
    forall a. a -> IO (IORef a)
    newIORef Bool
    False
        if Settings -> Bool
    settingsHTTP2Enabled Settings
    settings Bool -> Bool -> Bool
    && Bool
    h2 then do
            Int -> Recv
    rawRecvN <- ByteString -> Recv -> RecvBuf -> IO (Int -> Recv)
    makeReceiveN ByteString
    bs (Connection -> Recv
    connRecv Connection
    conn) (Connection -> RecvBuf
    connRecvBuf Connection
    conn)
            -- This thread becomes the sender in http2 library.
            -- In the case of event source, one request comes and one
            -- worker gets busy. But it is likely that the receiver does
            -- not receive any data at all while the sender is sending
            -- output data from the worker. It's not good enough to tickle
            -- the time handler in the receiver only. So, we should tickle
            -- the time handler in both the receiver and the sender.
            let recvN :: Int -> Recv
    recvN = Handle -> IORef Bool -> Int -> (Int -> Recv) -> Int -> Recv
    wrappedRecvN Handle
    th IORef Bool
    istatus (Settings -> Int
    settingsSlowlorisSize Settings
    settings) Int -> Recv
    rawRecvN
                sendBS :: ByteString -> IO ()
    sendBS x :: ByteString
    x = Connection -> ByteString -> IO ()
    connSendAll Connection
    conn ByteString
    x IO () -> IO () -> IO ()
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Handle -> IO ()
    T.tickle Handle
    th
            -- fixme: origAddr
            IO ()
    checkTLS
            Connection -> Bool -> IO ()
    setConnHTTP2 Connection
    conn Bool
    True
            Settings
    -> InternalInfo
    -> Connection
    -> Transport
    -> SockAddr
    -> (Int -> Recv)
    -> (ByteString -> IO ())
    -> Application
    -> IO ()
    http2 Settings
    settings InternalInfo
    ii Connection
    conn Transport
    transport SockAddr
    origAddr Int -> Recv
    recvN ByteString -> IO ()
    sendBS Application
    app
          else do
            Source
    src <- Recv -> IO Source
    mkSource (Connection -> Handle -> IORef Bool -> Int -> Recv
    wrappedRecv Connection
    conn Handle
    th IORef Bool
    istatus (Settings -> Int
    settingsSlowlorisSize Settings
    settings))
            IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    istatus Bool
    True
            Source -> ByteString -> IO ()
    leftoverSource Source
    src ByteString
    bs
            SockAddr
    addr <- Source -> IO SockAddr
    getProxyProtocolAddr Source
    src
            Bool -> SockAddr -> IORef Bool -> Source -> IO ()
    http1 Bool
    True SockAddr
    addr IORef Bool
    istatus Source
    src IO () -> (SomeException -> IO ()) -> IO ()
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `E.catch` \e :: SomeException
    e ->
              case () of
                ()
                 -- See comment below referencing
                 -- https://github.com/yesodweb/wai/issues/618
                 | Just NoKeepAliveRequest <- SomeException -> Maybe NoKeepAliveRequest
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    e -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                 -- No valid request
                 | Just (BadFirstLine _)   <- SomeException -> Maybe InvalidRequest
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    e -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                 | Bool
    otherwise -> do
                   Bool
    _ <- Request -> IORef Bool -> SomeException -> IO Bool
    sendErrorResponse (SockAddr -> Request
    dummyreq SockAddr
    addr) IORef Bool
    istatus SomeException
    e
                   SomeException -> IO ()
    forall e a. Exception e => e -> IO a
    throwIO SomeException
    e

      where
        getProxyProtocolAddr :: Source -> IO SockAddr
    getProxyProtocolAddr src :: Source
    src =
            case Settings -> ProxyProtocol
    settingsProxyProtocol Settings
    settings of
                ProxyProtocolNone ->
                    SockAddr -> IO SockAddr
    forall (m :: * -> *) a. Monad m => a -> m a
    return SockAddr
    origAddr
                ProxyProtocolRequired -> do
                    ByteString
    seg <- Source -> Recv
    readSource Source
    src
                    Source -> ByteString -> IO SockAddr
    parseProxyProtocolHeader Source
    src ByteString
    seg
                ProxyProtocolOptional -> do
                    ByteString
    seg <- Source -> Recv
    readSource Source
    src
                    if ByteString -> ByteString -> Bool
    S.isPrefixOf "PROXY " ByteString
    seg
                        then Source -> ByteString -> IO SockAddr
    parseProxyProtocolHeader Source
    src ByteString
    seg
                        else do Source -> ByteString -> IO ()
    leftoverSource Source
    src ByteString
    seg
                                SockAddr -> IO SockAddr
    forall (m :: * -> *) a. Monad m => a -> m a
    return SockAddr
    origAddr

        parseProxyProtocolHeader :: Source -> ByteString -> IO SockAddr
    parseProxyProtocolHeader src :: Source
    src seg :: ByteString
    seg = do
            let (header :: ByteString
    header,seg' :: ByteString
    seg') = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
    S.break (Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == 0x0d) ByteString
    seg -- 0x0d == CR
                maybeAddr :: Maybe SockAddr
    maybeAddr = case Word8 -> ByteString -> [ByteString]
    S.split 0x20 ByteString
    header of -- 0x20 == space
                    ["PROXY","TCP4",clientAddr :: ByteString
    clientAddr,_,clientPort :: ByteString
    clientPort,_] ->
                        case [IPv4
    x | (x :: IPv4
    x, t :: String
    t) <- ReadS IPv4
    forall a. Read a => ReadS a
    reads (ByteString -> String
    decodeAscii ByteString
    clientAddr), String -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    t] of
                            [a :: IPv4
    a] -> SockAddr -> Maybe SockAddr
    forall a. a -> Maybe a
    Just (PortNumber -> HostAddress -> SockAddr
    SockAddrInet (ByteString -> PortNumber
    forall a. Integral a => ByteString -> a
    readInt ByteString
    clientPort)
                                                           (IPv4 -> HostAddress
    toHostAddress IPv4
    a))
                            _ -> Maybe SockAddr
    forall a. Maybe a
    Nothing
                    ["PROXY","TCP6",clientAddr :: ByteString
    clientAddr,_,clientPort :: ByteString
    clientPort,_] ->
                        case [IPv6
    x | (x :: IPv6
    x, t :: String
    t) <- ReadS IPv6
    forall a. Read a => ReadS a
    reads (ByteString -> String
    decodeAscii ByteString
    clientAddr), String -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    t] of
                            [a :: IPv6
    a] -> SockAddr -> Maybe SockAddr
    forall a. a -> Maybe a
    Just (PortNumber
    -> HostAddress -> HostAddress6 -> HostAddress -> SockAddr
    SockAddrInet6 (ByteString -> PortNumber
    forall a. Integral a => ByteString -> a
    readInt ByteString
    clientPort)
                                                            0
                                                            (IPv6 -> HostAddress6
    toHostAddress6 IPv6
    a)
                                                            0)
                            _ -> Maybe SockAddr
    forall a. Maybe a
    Nothing
                    ("PROXY":"UNKNOWN":_) ->
                        SockAddr -> Maybe SockAddr
    forall a. a -> Maybe a
    Just SockAddr
    origAddr
                    _ ->
                        Maybe SockAddr
    forall a. Maybe a
    Nothing
            case Maybe SockAddr
    maybeAddr of
                Nothing -> InvalidRequest -> IO SockAddr
    forall e a. Exception e => e -> IO a
    throwIO (String -> InvalidRequest
    BadProxyHeader (ByteString -> String
    decodeAscii ByteString
    header))
                Just a :: SockAddr
    a -> do Source -> ByteString -> IO ()
    leftoverSource Source
    src (Int -> ByteString -> ByteString
    S.drop 2 ByteString
    seg') -- drop CRLF
                             SockAddr -> IO SockAddr
    forall (m :: * -> *) a. Monad m => a -> m a
    return SockAddr
    a

        decodeAscii :: ByteString -> String
    decodeAscii = (Word8 -> Char) -> [Word8] -> String
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> Char
    chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Word8 -> Int
    forall a. Enum a => a -> Int
    fromEnum) ([Word8] -> String)
    -> (ByteString -> [Word8]) -> ByteString -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> [Word8]
    S.unpack

        shouldSendErrorResponse :: SomeException -> Bool
    shouldSendErrorResponse se :: SomeException
    se
            | Just ConnectionClosedByPeer <- SomeException -> Maybe InvalidRequest
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    se = Bool
    False
            | Bool
    otherwise                                       = Bool
    True

        sendErrorResponse :: Request -> IORef Bool -> SomeException -> IO Bool
    sendErrorResponse req :: Request
    req istatus :: IORef Bool
    istatus e :: SomeException
    e = do
            Bool
    status <- IORef Bool -> IO Bool
    forall a. IORef a -> IO a
    readIORef IORef Bool
    istatus
            if SomeException -> Bool
    shouldSendErrorResponse SomeException
    e Bool -> Bool -> Bool
    && Bool
    status
                then do
                    Settings
    -> Connection
    -> InternalInfo
    -> Handle
    -> Request
    -> IndexedHeader
    -> Recv
    -> Response
    -> IO Bool
    sendResponse Settings
    settings Connection
    conn InternalInfo
    ii Handle
    th Request
    req IndexedHeader
    defaultIndexRequestHeader (ByteString -> Recv
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    S.empty) (SomeException -> Response
    errorResponse SomeException
    e)
                else Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

        dummyreq :: SockAddr -> Request
    dummyreq addr :: SockAddr
    addr = Request
    defaultRequest { remoteHost :: SockAddr
    remoteHost = SockAddr
    addr }

        errorResponse :: SomeException -> Response
    errorResponse e :: SomeException
    e = Settings -> SomeException -> Response
    settingsOnExceptionResponse Settings
    settings SomeException
    e

        http1 :: Bool -> SockAddr -> IORef Bool -> Source -> IO ()
    http1 firstRequest :: Bool
    firstRequest addr :: SockAddr
    addr istatus :: IORef Bool
    istatus src :: Source
    src = do
            (req :: Request
    req, mremainingRef :: Maybe (IORef Int)
    mremainingRef, idxhdr :: IndexedHeader
    idxhdr, nextBodyFlush :: Recv
    nextBodyFlush) <- Bool
    -> Settings
    -> Connection
    -> InternalInfo
    -> Handle
    -> SockAddr
    -> Source
    -> Transport
    -> IO (Request, Maybe (IORef Int), IndexedHeader, Recv)
    recvRequest Bool
    firstRequest Settings
    settings Connection
    conn InternalInfo
    ii Handle
    th SockAddr
    addr Source
    src Transport
    transport
            Bool
    keepAlive <- IORef Bool
    -> Source
    -> Request
    -> Maybe (IORef Int)
    -> IndexedHeader
    -> Recv
    -> IO Bool
    processRequest IORef Bool
    istatus Source
    src Request
    req Maybe (IORef Int)
    mremainingRef IndexedHeader
    idxhdr Recv
    nextBodyFlush
                IO Bool -> (SomeException -> IO Bool) -> IO Bool
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `E.catch` \e :: SomeException
    e -> do
                    Settings -> Maybe Request -> SomeException -> IO ()
    settingsOnException Settings
    settings (Request -> Maybe Request
    forall a. a -> Maybe a
    Just Request
    req) SomeException
    e
                    -- Don't throw the error again to prevent calling settingsOnException twice.
                    Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

            -- When doing a keep-alive connection, the other side may just
            -- close the connection. We don't want to treat that as an
            -- exceptional situation, so we pass in False to http1 (which
            -- in turn passes in False to recvRequest), indicating that
            -- this is not the first request. If, when trying to read the
            -- request headers, no data is available, recvRequest will
            -- throw a NoKeepAliveRequest exception, which we catch here
            -- and ignore. See: https://github.com/yesodweb/wai/issues/618
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    keepAlive (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Bool -> SockAddr -> IORef Bool -> Source -> IO ()
    http1 Bool
    False SockAddr
    addr IORef Bool
    istatus Source
    src

        processRequest :: IORef Bool
    -> Source
    -> Request
    -> Maybe (IORef Int)
    -> IndexedHeader
    -> Recv
    -> IO Bool
    processRequest istatus :: IORef Bool
    istatus src :: Source
    src req :: Request
    req mremainingRef :: Maybe (IORef Int)
    mremainingRef idxhdr :: IndexedHeader
    idxhdr nextBodyFlush :: Recv
    nextBodyFlush = do
            -- Let the application run for as long as it wants
            Handle -> IO ()
    T.pause Handle
    th

            -- In the event that some scarce resource was acquired during
            -- creating the request, we need to make sure that we don't get
            -- an async exception before calling the ResponseSource.
            IORef Bool
    keepAliveRef <- Bool -> IO (IORef Bool)
    forall a. a -> IO (IORef a)
    newIORef (Bool -> IO (IORef Bool)) -> Bool -> IO (IORef Bool)
    forall a b. (a -> b) -> a -> b
    $ String -> Bool
    forall a. HasCallStack => String -> a
    error "keepAliveRef not filled"
            Either SomeException ResponseReceived
    r <- IO ResponseReceived -> IO (Either SomeException ResponseReceived)
    forall e a. Exception e => IO a -> IO (Either e a)
    E.try (IO ResponseReceived -> IO (Either SomeException ResponseReceived))
    -> IO ResponseReceived
    -> IO (Either SomeException ResponseReceived)
    forall a b. (a -> b) -> a -> b
    $ Application
    app Request
    req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
    -> (Response -> IO ResponseReceived) -> IO ResponseReceived
    forall a b. (a -> b) -> a -> b
    $ \res :: Response
    res -> do
                Handle -> IO ()
    T.resume Handle
    th
                -- FIXME consider forcing evaluation of the res here to
                -- send more meaningful error messages to the user.
                -- However, it may affect performance.
                IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    istatus Bool
    False
                Bool
    keepAlive <- Settings
    -> Connection
    -> InternalInfo
    -> Handle
    -> Request
    -> IndexedHeader
    -> Recv
    -> Response
    -> IO Bool
    sendResponse Settings
    settings Connection
    conn InternalInfo
    ii Handle
    th Request
    req IndexedHeader
    idxhdr (Source -> Recv
    readSource Source
    src) Response
    res
                IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    keepAliveRef Bool
    keepAlive
                ResponseReceived -> IO ResponseReceived
    forall (m :: * -> *) a. Monad m => a -> m a
    return ResponseReceived
    ResponseReceived
            case Either SomeException ResponseReceived
    r of
                Right ResponseReceived -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                Left e :: SomeException
    e@(SomeException _)
                  | Just (ExceptionInsideResponseBody e' :: SomeException
    e') <- SomeException -> Maybe ExceptionInsideResponseBody
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    e -> SomeException -> IO ()
    forall e a. Exception e => e -> IO a
    throwIO SomeException
    e'
                  | Bool
    otherwise -> do
                        Bool
    keepAlive <- Request -> IORef Bool -> SomeException -> IO Bool
    sendErrorResponse Request
    req IORef Bool
    istatus SomeException
    e
                        Settings -> Maybe Request -> SomeException -> IO ()
    settingsOnException Settings
    settings (Request -> Maybe Request
    forall a. a -> Maybe a
    Just Request
    req) SomeException
    e
                        IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    keepAliveRef Bool
    keepAlive

            Bool
    keepAlive <- IORef Bool -> IO Bool
    forall a. IORef a -> IO a
    readIORef IORef Bool
    keepAliveRef

            -- We just send a Response and it takes a time to
            -- receive a Request again. If we immediately call recv,
            -- it is likely to fail and cause the IO manager to do some work.
            -- It is very costly, so we yield to another Haskell
            -- thread hoping that the next Request will arrive
            -- when this Haskell thread will be re-scheduled.
            -- This improves performance at least when
            -- the number of cores is small.
            IO ()
    Conc.yield

            if Bool
    keepAlive
              then
                -- If there is an unknown or large amount of data to still be read
                -- from the request body, simple drop this connection instead of
                -- reading it all in to satisfy a keep-alive request.
                case Settings -> Maybe Int
    settingsMaximumBodyFlush Settings
    settings of
                    Nothing -> do
                        Recv -> IO ()
    flushEntireBody Recv
    nextBodyFlush
                        Handle -> IO ()
    T.resume Handle
    th
                        Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
                    Just maxToRead :: Int
    maxToRead -> do
                        let tryKeepAlive :: IO Bool
    tryKeepAlive = do
                                -- flush the rest of the request body
                                Bool
    isComplete <- Recv -> Int -> IO Bool
    flushBody Recv
    nextBodyFlush Int
    maxToRead
                                if Bool
    isComplete then do
                                    Handle -> IO ()
    T.resume Handle
    th
                                    Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
                                  else
                                    Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
                        case Maybe (IORef Int)
    mremainingRef of
                            Just ref :: IORef Int
    ref -> do
                                Int
    remaining <- IORef Int -> IO Int
    forall a. IORef a -> IO a
    readIORef IORef Int
    ref
                                if Int
    remaining Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    maxToRead then
                                    IO Bool
    tryKeepAlive
                                  else
                                    Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
                            Nothing -> IO Bool
    tryKeepAlive
              else
                Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

        checkTLS :: IO ()
    checkTLS = case Transport
    transport of
            TCP -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return () -- direct
            tls :: Transport
    tls -> Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (Transport -> Bool
    tls12orLater Transport
    tls) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Connection -> ErrorCodeId -> ByteString -> IO ()
    goaway Connection
    conn ErrorCodeId
    H2.InadequateSecurity "Weak TLS"
        tls12orLater :: Transport -> Bool
    tls12orLater tls :: Transport
    tls = Transport -> Int
    tlsMajorVersion Transport
    tls Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == 3 Bool -> Bool -> Bool
    && Transport -> Int
    tlsMinorVersion Transport
    tls Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= 3

    -- connClose must not be called here since Run:fork calls it
    goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()
    goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()
    goaway Connection{..} etype :: ErrorCodeId
    etype debugmsg :: ByteString
    debugmsg = ByteString -> IO ()
    connSendAll ByteString
    bytestream
      where
        einfo :: EncodeInfo
    einfo = (Word8 -> Word8) -> Int -> EncodeInfo
    H2.encodeInfo Word8 -> Word8
    forall a. a -> a
    id 0
        frame :: FramePayload
    frame = Int -> ErrorCodeId -> ByteString -> FramePayload
    H2.GoAwayFrame 0 ErrorCodeId
    etype ByteString
    debugmsg
        bytestream :: ByteString
    bytestream = EncodeInfo -> FramePayload -> ByteString
    H2.encodeFrame EncodeInfo
    einfo FramePayload
    frame

    flushEntireBody :: IO ByteString -> IO ()
    flushEntireBody :: Recv -> IO ()
    flushEntireBody src :: Recv
    src =
        IO ()
    loop
      where
        loop :: IO ()
    loop = do
            ByteString
    bs <- Recv
    src
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (ByteString -> Bool
    S.null ByteString
    bs) IO ()
    loop

    flushBody :: IO ByteString -- ^ get next chunk
              -> Int -- ^ maximum to flush
              -> IO Bool -- ^ True == flushed the entire body, False == we didn't
    flushBody :: Recv -> Int -> IO Bool
    flushBody src :: Recv
    src =
        Int -> IO Bool
    loop
      where
        loop :: Int -> IO Bool
    loop toRead :: Int
    toRead = do
            ByteString
    bs <- Recv
    src
            let toRead' :: Int
    toRead' = Int
    toRead Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - ByteString -> Int
    S.length ByteString
    bs
            case () of
                ()
                    | ByteString -> Bool
    S.null ByteString
    bs -> Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
                    | Int
    toRead' Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= 0 -> Int -> IO Bool
    loop Int
    toRead'
                    | Bool
    otherwise -> Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    wrappedRecv :: Connection -> T.Handle -> IORef Bool -> Int -> IO ByteString
    wrappedRecv :: Connection -> Handle -> IORef Bool -> Int -> Recv
    wrappedRecv Connection { connRecv :: Connection -> Recv
    connRecv = Recv
    recv } th :: Handle
    th istatus :: IORef Bool
    istatus slowlorisSize :: Int
    slowlorisSize = do
        ByteString
    bs <- Recv
    recv
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (ByteString -> Bool
    S.null ByteString
    bs) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
            IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    istatus Bool
    True
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (ByteString -> Int
    S.length ByteString
    bs Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    slowlorisSize) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Handle -> IO ()
    T.tickle Handle
    th
        ByteString -> Recv
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    bs

    wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)
    wrappedRecvN :: Handle -> IORef Bool -> Int -> (Int -> Recv) -> Int -> Recv
    wrappedRecvN th :: Handle
    th istatus :: IORef Bool
    istatus slowlorisSize :: Int
    slowlorisSize readN :: Int -> Recv
    readN bufsize :: Int
    bufsize = do
        ByteString
    bs <- Int -> Recv
    readN Int
    bufsize
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (ByteString -> Bool
    S.null ByteString
    bs) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
            IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    istatus Bool
    True
        -- TODO: think about the slowloris protection in HTTP2: current code
        -- might open a slow-loris attack vector. Rather than timing we should
        -- consider limiting the per-client connections assuming that in HTTP2
        -- we should allow only few connections per host (real-world
        -- deployments with large NATs may be trickier).
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (ByteString -> Int
    S.length ByteString
    bs Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    slowlorisSize Bool -> Bool -> Bool
    || Int
    bufsize Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    slowlorisSize) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Handle -> IO ()
    T.tickle Handle
    th
        ByteString -> Recv
    forall (m :: * -> *) a. Monad m => a -> m a
    return 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
    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 set :: Settings
    set counter :: Counter
    counter =
        case Settings -> Maybe Int
    settingsGracefulShutdownTimeout Settings
    set of
            Nothing ->
                Counter -> IO ()
    waitForZero Counter
    counter
            (Just seconds :: 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 = 1000000