    {-# LANGUAGE CPP #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE PackageImports #-}
    {-# LANGUAGE PatternGuards #-}
    {-# LANGUAGE ScopedTypeVariables #-}

    module Network.Wai.Handler.Warp.HTTP1 (
        http1,
    ) where

    import qualified Control.Concurrent as Conc (yield)
    import Control.Exception (SomeException, catch, fromException, throwIO, try)
    import qualified Data.ByteString as BS
    import Data.Char (chr)
    import Data.IORef (IORef, newIORef, readIORef, writeIORef)
    import Data.Word8 (_cr, _space)
    import Network.Socket (SockAddr (SockAddrInet, SockAddrInet6))
    import Network.Wai
    import Network.Wai.Internal (ResponseReceived (ResponseReceived))
    import qualified System.TimeManager as T
    import "iproute" Data.IP (toHostAddress, toHostAddress6)

    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.Request
    import Network.Wai.Handler.Warp.Response
    import Network.Wai.Handler.Warp.Settings
    import Network.Wai.Handler.Warp.Types

    http1
        :: Settings
        -> InternalInfo
        -> Connection
        -> Transport
        -> Application
        -> SockAddr
        -> T.Handle
        -> ByteString
        -> IO ()
    http1 :: 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
    bs0 = do
        istatus <- Bool -> IO (IORef Bool)
    forall a. a -> IO (IORef a)
    newIORef Bool
    True
        src <- mkSource (wrappedRecv conn istatus (settingsSlowlorisSize settings))
        leftoverSource src bs0
        addr <- getProxyProtocolAddr src
        http1server settings ii conn transport app addr th istatus src
      where
        wrappedRecv :: Connection -> IORef Bool -> Int -> IO ByteString
    wrappedRecv Connection{connRecv :: Connection -> IO ByteString
    connRecv = IO ByteString
    recv} IORef Bool
    istatus Int
    slowlorisSize = do
            bs <- IO ByteString
    recv
            unless (BS.null bs) $ do
                writeIORef istatus True
                when (BS.length bs >= slowlorisSize) $ T.tickle th
            return bs

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

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

    http1server
        :: Settings
        -> InternalInfo
        -> Connection
        -> Transport
        -> Application
        -> SockAddr
        -> T.Handle
        -> IORef Bool
        -> Source
        -> IO ()
    http1server :: Settings
    -> InternalInfo
    -> Connection
    -> Transport
    -> Application
    -> SockAddr
    -> Handle
    -> IORef Bool
    -> Source
    -> IO ()
    http1server Settings
    settings InternalInfo
    ii Connection
    conn Transport
    transport Application
    app SockAddr
    addr Handle
    th IORef Bool
    istatus Source
    src =
        FirstRequest -> IO ()
    loop FirstRequest
    FirstRequest IO () -> (SomeException -> IO ()) -> IO ()
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `catch` SomeException -> IO ()
    handler
      where
        handler :: SomeException -> IO ()
    handler SomeException
    e
            -- See comment below referencing
            -- https://github.com/yesodweb/wai/issues/618
            | Just NoKeepAliveRequest
    NoKeepAliveRequest <- SomeException -> Maybe NoKeepAliveRequest
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    e = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            -- No valid request
            | Just (BadFirstLine String
    _) <- SomeException -> Maybe InvalidRequest
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    e = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            | SomeException -> Bool
    forall e. Exception e => e -> Bool
    isAsyncException SomeException
    e = SomeException -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO SomeException
    e
            | Bool
    otherwise = do
                _ <-
                    Settings
    -> InternalInfo
    -> Connection
    -> Handle
    -> IORef Bool
    -> Request
    -> SomeException
    -> IO Bool
    sendErrorResponse
                        Settings
    settings
                        InternalInfo
    ii
                        Connection
    conn
                        Handle
    th
                        IORef Bool
    istatus
                        Request
    defaultRequest{remoteHost = addr}
                        SomeException
    e
                throwIO e

        loop :: FirstRequest -> IO ()
    loop FirstRequest
    firstRequest = do
            (req, mremainingRef, idxhdr, nextBodyFlush) <-
                FirstRequest
    -> Settings
    -> Connection
    -> InternalInfo
    -> Handle
    -> SockAddr
    -> Source
    -> Transport
    -> IO (Request, Maybe (IORef Int), IndexedHeader, IO ByteString)
    recvRequest FirstRequest
    firstRequest Settings
    settings Connection
    conn InternalInfo
    ii Handle
    th SockAddr
    addr Source
    src Transport
    transport
            keepAlive <-
                processRequest
                    settings
                    ii
                    conn
                    app
                    th
                    istatus
                    src
                    req
                    mremainingRef
                    idxhdr
                    nextBodyFlush
                    `catch` \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.
                        ReuseConnection -> IO ReuseConnection
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ReuseConnection
    CloseConnection

            -- 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 SubsequentRequest to http1 (which
            -- in turn passes in SubsequentRequest 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

            case keepAlive of
                ReuseConnection
    ReuseConnection -> FirstRequest -> IO ()
    loop FirstRequest
    SubsequentRequest
                ReuseConnection
    CloseConnection -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    data ReuseConnection = ReuseConnection | CloseConnection

    processRequest
        :: Settings
        -> InternalInfo
        -> Connection
        -> Application
        -> T.Handle
        -> IORef Bool
        -> Source
        -> Request
        -> Maybe (IORef Int)
        -> IndexedHeader
        -> IO ByteString
        -> IO ReuseConnection
    processRequest :: Settings
    -> InternalInfo
    -> Connection
    -> Application
    -> Handle
    -> IORef Bool
    -> Source
    -> Request
    -> Maybe (IORef Int)
    -> IndexedHeader
    -> IO ByteString
    -> IO ReuseConnection
    processRequest Settings
    settings InternalInfo
    ii Connection
    conn Application
    app Handle
    th IORef Bool
    istatus Source
    src Request
    req Maybe (IORef Int)
    mremainingRef IndexedHeader
    idxhdr IO ByteString
    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.
        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 String
    "keepAliveRef not filled"
        r <- try $ app req $ \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
            keepAlive <- Settings
    -> Connection
    -> InternalInfo
    -> Handle
    -> Request
    -> IndexedHeader
    -> IO ByteString
    -> Response
    -> IO Bool
    sendResponse Settings
    settings Connection
    conn InternalInfo
    ii Handle
    th Request
    req IndexedHeader
    idxhdr (Source -> IO ByteString
    readSource Source
    src) Response
    res
            writeIORef keepAliveRef keepAlive
            return ResponseReceived
        case r of
            Right ResponseReceived
    ResponseReceived -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            Left (SomeException
    e :: SomeException)
                | Just (ExceptionInsideResponseBody SomeException
    e') <- SomeException -> Maybe ExceptionInsideResponseBody
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    e -> SomeException -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO SomeException
    e'
                | SomeException -> Bool
    forall e. Exception e => e -> Bool
    isAsyncException SomeException
    e -> SomeException -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO SomeException
    e
                | Bool
    otherwise -> do
                    keepAlive <- Settings
    -> InternalInfo
    -> Connection
    -> Handle
    -> IORef Bool
    -> Request
    -> SomeException
    -> IO Bool
    sendErrorResponse Settings
    settings InternalInfo
    ii Connection
    conn Handle
    th IORef Bool
    istatus Request
    req SomeException
    e
                    settingsOnException settings (Just req) e
                    writeIORef keepAliveRef keepAlive

        keepAlive <- readIORef 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.
        Conc.yield

        if 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 settingsMaximumBodyFlush settings of
                    Maybe Int
    Nothing -> do
                        IO ByteString -> IO ()
    flushEntireBody IO ByteString
    nextBodyFlush
                        Handle -> IO ()
    T.resume Handle
    th
                        ReuseConnection -> IO ReuseConnection
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ReuseConnection
    ReuseConnection
                    Just Int
    maxToRead -> do
                        let tryKeepAlive :: IO ReuseConnection
    tryKeepAlive = do
                                -- flush the rest of the request body
                                isComplete <- IO ByteString -> Int -> IO Bool
    flushBody IO ByteString
    nextBodyFlush Int
    maxToRead
                                if isComplete
                                    then do
                                        T.resume th
                                        return ReuseConnection
                                    else return CloseConnection
                        case Maybe (IORef Int)
    mremainingRef of
                            Just IORef Int
    ref -> do
                                remaining <- IORef Int -> IO Int
    forall a. IORef a -> IO a
    readIORef IORef Int
    ref
                                if remaining <= maxToRead
                                    then tryKeepAlive
                                    else return CloseConnection
                            Maybe (IORef Int)
    Nothing -> IO ReuseConnection
    tryKeepAlive
            else return CloseConnection

    sendErrorResponse
        :: Settings
        -> InternalInfo
        -> Connection
        -> T.Handle
        -> IORef Bool
        -> Request
        -> SomeException
        -> IO Bool
    sendErrorResponse :: Settings
    -> InternalInfo
    -> Connection
    -> Handle
    -> IORef Bool
    -> Request
    -> SomeException
    -> IO Bool
    sendErrorResponse Settings
    settings InternalInfo
    ii Connection
    conn Handle
    th IORef Bool
    istatus Request
    req SomeException
    e = do
        status <- IORef Bool -> IO Bool
    forall a. IORef a -> IO a
    readIORef IORef Bool
    istatus
        if shouldSendErrorResponse e && status
            then
                sendResponse
                    settings
                    conn
                    ii
                    th
                    req
                    defaultIndexRequestHeader
                    (return BS.empty)
                    errorResponse
            else return False
      where
        shouldSendErrorResponse :: SomeException -> Bool
    shouldSendErrorResponse SomeException
    se
            | Just InvalidRequest
    ConnectionClosedByPeer <- SomeException -> Maybe InvalidRequest
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    se = Bool
    False
            | Bool
    otherwise = Bool
    True
        errorResponse :: Response
    errorResponse = Settings -> SomeException -> Response
    settingsOnExceptionResponse Settings
    settings SomeException
    e

    flushEntireBody :: IO ByteString -> IO ()
    flushEntireBody :: IO ByteString -> IO ()
    flushEntireBody IO ByteString
    src =
        IO ()
    loop
      where
        loop :: IO ()
    loop = do
            bs <- IO ByteString
    src
            unless (BS.null bs) loop

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