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

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

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

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 <- 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ do
            forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
istatus Bool
True
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
BS.length ByteString
bs forall a. Ord a => a -> a -> Bool
>= Int
slowlorisSize) forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
T.tickle Handle
th
        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 ->
                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
                            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 (forall a. Eq a => a -> a -> Bool
== Word8
0x0d) ByteString
seg -- 0x0d == CR
            maybeAddr :: Maybe SockAddr
maybeAddr = case Word8 -> ByteString -> [ByteString]
BS.split Word8
0x20 ByteString
header of -- 0x20 == space
                [ByteString
"PROXY",ByteString
"TCP4",ByteString
clientAddr,ByteString
_,ByteString
clientPort,ByteString
_] ->
                    case [IPv4
x | (IPv4
x, String
t) <- forall a. Read a => ReadS a
reads (ByteString -> String
decodeAscii ByteString
clientAddr), forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t] of
                        [IPv4
a] -> forall a. a -> Maybe a
Just (PortNumber -> FlowInfo -> SockAddr
SockAddrInet (forall a. Integral a => ByteString -> a
readInt ByteString
clientPort)
                                                       (IPv4 -> FlowInfo
toHostAddress IPv4
a))
                        [IPv4]
_ -> forall a. Maybe a
Nothing
                [ByteString
"PROXY",ByteString
"TCP6",ByteString
clientAddr,ByteString
_,ByteString
clientPort,ByteString
_] ->
                    case [IPv6
x | (IPv6
x, String
t) <- forall a. Read a => ReadS a
reads (ByteString -> String
decodeAscii ByteString
clientAddr), forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t] of
                        [IPv6
a] -> forall a. a -> Maybe a
Just (PortNumber -> FlowInfo -> HostAddress6 -> FlowInfo -> SockAddr
SockAddrInet6 (forall a. Integral a => ByteString -> a
readInt ByteString
clientPort)
                                                        FlowInfo
0
                                                        (IPv6 -> HostAddress6
toHostAddress6 IPv6
a)
                                                        FlowInfo
0)
                        [IPv6]
_ -> forall a. Maybe a
Nothing
                (ByteString
"PROXY":ByteString
"UNKNOWN":[ByteString]
_) ->
                    forall a. a -> Maybe a
Just SockAddr
origAddr
                [ByteString]
_ ->
                    forall a. Maybe a
Nothing
        case Maybe SockAddr
maybeAddr of
            Maybe SockAddr
Nothing -> 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
                         forall (m :: * -> *) a. Monad m => a -> m a
return SockAddr
a

    decodeAscii :: ByteString -> String
decodeAscii = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) 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 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 <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      -- No valid request
      | Just (BadFirstLine String
_)   <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = 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 :: SockAddr
remoteHost = SockAddr
addr } SomeException
e
          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
            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 (forall a. a -> Maybe a
Just Request
req) SomeException
e
                -- Don't throw the error again to prevent calling settingsOnException twice.
                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

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
keepAlive 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 <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"keepAliveRef not filled"
    Either SomeException ResponseReceived
r <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UnliftIO.tryAny forall a b. (a -> b) -> a -> b
$ Application
app Request
req 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.
        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
        forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
keepAliveRef Bool
keepAlive
        forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ResponseReceived
    case Either SomeException ResponseReceived
r of
        Right ResponseReceived
ResponseReceived -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Left (SomeException
e :: SomeException)
          | Just (ExceptionInsideResponseBody SomeException
e') <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> 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 (forall a. a -> Maybe a
Just Request
req) SomeException
e
                forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
keepAliveRef Bool
keepAlive

    Bool
keepAlive <- 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
                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
                            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                          else
                            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                case Maybe (IORef Int)
mremainingRef of
                    Just IORef Int
ref -> do
                        Int
remaining <- forall a. IORef a -> IO a
readIORef IORef Int
ref
                        if Int
remaining forall a. Ord a => a -> a -> Bool
<= Int
maxToRead then
                            IO Bool
tryKeepAlive
                          else
                            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                    Maybe (IORef Int)
Nothing -> IO Bool
tryKeepAlive
      else
        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 <- 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 (forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
BS.empty) Response
errorResponse
      else
        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    shouldSendErrorResponse :: SomeException -> Bool
shouldSendErrorResponse SomeException
se
      | Just InvalidRequest
ConnectionClosedByPeer <- 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
        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 forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
bs
        case () of
            ()
                | ByteString -> Bool
BS.null ByteString
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                | Int
toRead' forall a. Ord a => a -> a -> Bool
>= Int
0 -> Int -> IO Bool
loop Int
toRead'
                | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False