{-# 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 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 UnliftIO (SomeException, fromException, throwIO)
import qualified UnliftIO
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
    IORef Bool
istatus <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
    Source
src <- IO ByteString -> IO Source
mkSource (Connection -> IORef Bool -> Int -> IO ByteString
wrappedRecv Connection
conn IORef Bool
istatus (Settings -> Int
settingsSlowlorisSize Settings
settings))
    Source -> ByteString -> IO ()
leftoverSource Source
src ByteString
bs0
    SockAddr
addr <- Source -> IO SockAddr
getProxyProtocolAddr Source
src
    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
  where
    wrappedRecv :: Connection -> IORef Bool -> Int -> IO ByteString
wrappedRecv Connection{connRecv :: Connection -> IO ByteString
connRecv = IO ByteString
recv} IORef Bool
istatus Int
slowlorisSize = do
        ByteString
bs <- IO ByteString
recv
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.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
BS.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 -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
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
                ByteString
seg <- Source -> IO ByteString
readSource Source
src
                Source -> ByteString -> IO SockAddr
parseProxyProtocolHeader Source
src ByteString
seg
            ProxyProtocol
ProxyProtocolOptional -> do
                ByteString
seg <- Source -> IO ByteString
readSource Source
src
                if ByteString -> ByteString -> Bool
BS.isPrefixOf ByteString
"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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SockAddr
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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m 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 =
    Bool -> IO ()
loop Bool
True IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UnliftIO.catchAny` 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 ()
        | Bool
otherwise = do
            Bool
_ <-
                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
            SomeException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e

    loop :: Bool -> IO ()
loop Bool
firstRequest = do
        (Request
req, Maybe (IORef Int)
mremainingRef, IndexedHeader
idxhdr, IO ByteString
nextBodyFlush) <-
            Bool
-> Settings
-> Connection
-> InternalInfo
-> Handle
-> SockAddr
-> Source
-> Transport
-> IO (Request, Maybe (IORef Int), IndexedHeader, IO ByteString)
recvRequest Bool
firstRequest Settings
settings Connection
conn InternalInfo
ii Handle
th SockAddr
addr Source
src Transport
transport
        Bool
keepAlive <-
            Settings
-> InternalInfo
-> Connection
-> Application
-> Handle
-> IORef Bool
-> Source
-> Request
-> Maybe (IORef Int)
-> IndexedHeader
-> IO ByteString
-> IO Bool
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
                IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UnliftIO.catchAny` \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 a. a -> IO a
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 -> IO ()
loop Bool
False

processRequest
    :: Settings
    -> InternalInfo
    -> Connection
    -> Application
    -> T.Handle
    -> IORef Bool
    -> Source
    -> Request
    -> Maybe (IORef Int)
    -> IndexedHeader
    -> IO ByteString
    -> IO Bool
processRequest :: Settings
-> InternalInfo
-> Connection
-> Application
-> Handle
-> IORef Bool
-> Source
-> Request
-> Maybe (IORef Int)
-> IndexedHeader
-> IO ByteString
-> IO Bool
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.
    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 String
"keepAliveRef not filled"
    Either SomeException ResponseReceived
r <- IO ResponseReceived -> IO (Either SomeException ResponseReceived)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UnliftIO.tryAny (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
$ \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
-> 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
        IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
keepAliveRef Bool
keepAlive
        ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ResponseReceived
    case Either SomeException ResponseReceived
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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e'
            | Bool
otherwise -> do
                Bool
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
                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
            Maybe Int
Nothing -> do
                IO ByteString -> IO ()
flushEntireBody IO ByteString
nextBodyFlush
                Handle -> IO ()
T.resume Handle
th
                Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Just Int
maxToRead -> do
                let tryKeepAlive :: IO Bool
tryKeepAlive = do
                        -- flush the rest of the request body
                        Bool
isComplete <- IO ByteString -> Int -> IO Bool
flushBody IO ByteString
nextBodyFlush Int
maxToRead
                        if Bool
isComplete
                            then do
                                Handle -> IO ()
T.resume Handle
th
                                Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                            else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                case Maybe (IORef Int)
mremainingRef of
                    Just 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                    Maybe (IORef Int)
Nothing -> IO Bool
tryKeepAlive
        else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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
    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
            Settings
-> Connection
-> InternalInfo
-> Handle
-> Request
-> IndexedHeader
-> IO ByteString
-> Response
-> IO Bool
sendResponse
                Settings
settings
                Connection
conn
                InternalInfo
ii
                Handle
th
                Request
req
                IndexedHeader
defaultIndexRequestHeader
                (ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
BS.empty)
                Response
errorResponse
        else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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
        ByteString
bs <- IO ByteString
src
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.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 :: IO ByteString -> Int -> IO Bool
flushBody IO ByteString
src = Int -> IO Bool
loop
  where
    loop :: Int -> IO Bool
loop Int
toRead = do
        ByteString
bs <- IO ByteString
src
        let toRead' :: Int
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