{-# 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')
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
| 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 ()
| 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
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
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
Handle -> IO ()
T.pause Handle
th
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
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
IO ()
Conc.yield
if Bool
keepAlive
then
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
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
-> Int
-> IO Bool
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