{-# 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 <- 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 (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 (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 (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 (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 (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 (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 (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 (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