{-# 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 Control.Exception as E
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 <- 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 (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 (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 (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
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) <- 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
                        [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))
                        [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 (t :: * -> *) a. Foldable t => t a -> Bool
null String
t] of
                        [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)
                                                        HostAddress
0
                                                        (IPv6 -> HostAddress6
toHostAddress6 IPv6
a)
                                                        HostAddress
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. 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 (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 e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.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 (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 (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
          SomeException -> IO ()
forall e a. Exception e => e -> IO 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 e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.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.
                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 -> 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 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
$ \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 (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ResponseReceived
    case Either SomeException ResponseReceived
r of
        Right ResponseReceived
ResponseReceived -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Left e :: SomeException
e@(SomeException e
_)
          | Just (ExceptionInsideResponseBody 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 <- 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 (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 (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 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
                    Maybe (IORef Int)
Nothing -> IO Bool
tryKeepAlive
      else
        Bool -> IO Bool
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 (m :: * -> *) a. Monad m => a -> m a
return ByteString
BS.empty) Response
errorResponse
      else
        Bool -> IO Bool
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 (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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False