{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Network.Wai.Handler.Warp.Request (
recvRequest,
headerLines,
pauseTimeoutKey,
getFileInfoKey,
#ifdef MIN_VERSION_crypton_x509
getClientCertificateKey,
#endif
NoKeepAliveRequest (..),
) where
import qualified Control.Concurrent as Conc (yield)
import Data.Array ((!))
import qualified Data.ByteString as S
import qualified Data.ByteString.Unsafe as SU
import qualified Data.CaseInsensitive as CI
import qualified Data.IORef as I
import Data.Typeable (Typeable)
import qualified Data.Vault.Lazy as Vault
import Data.Word8 (_cr, _lf)
#ifdef MIN_VERSION_crypton_x509
import Data.X509
#endif
import UnliftIO (Exception, throwIO)
import qualified Network.HTTP.Types as H
import Network.Socket (SockAddr)
import Network.Wai
import Network.Wai.Handler.Warp.Types
import Network.Wai.Internal
import System.IO.Unsafe (unsafePerformIO)
import qualified System.TimeManager as Timeout
import Prelude hiding (lines)
import Network.Wai.Handler.Warp.Conduit
import Network.Wai.Handler.Warp.FileInfoCache
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.RequestHeader
import Network.Wai.Handler.Warp.Settings (
Settings,
settingsMaxTotalHeaderLength,
settingsNoParsePath,
)
recvRequest
:: Bool
-> Settings
-> Connection
-> InternalInfo
-> Timeout.Handle
-> SockAddr
-> Source
-> Transport
-> IO
( Request
, Maybe (I.IORef Int)
, IndexedHeader
, IO ByteString
)
recvRequest :: Bool
-> Settings
-> Connection
-> InternalInfo
-> Handle
-> SockAddr
-> Source
-> Transport
-> IO (Request, Maybe (IORef Int), IndexedHeader, IO HeaderValue)
recvRequest Bool
firstRequest Settings
settings Connection
conn InternalInfo
ii Handle
th SockAddr
addr Source
src Transport
transport = do
[HeaderValue]
hdrlines <- Int -> Bool -> Source -> IO [HeaderValue]
headerLines (Settings -> Int
settingsMaxTotalHeaderLength Settings
settings) Bool
firstRequest Source
src
(HeaderValue
method, HeaderValue
unparsedPath, HeaderValue
path, HeaderValue
query, HttpVersion
httpversion, RequestHeaders
hdr) <-
[HeaderValue]
-> IO
(HeaderValue, HeaderValue, HeaderValue, HeaderValue, HttpVersion,
RequestHeaders)
parseHeaderLines [HeaderValue]
hdrlines
let idxhdr :: IndexedHeader
idxhdr = RequestHeaders -> IndexedHeader
indexRequestHeader RequestHeaders
hdr
expect :: Maybe HeaderValue
expect = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqExpect
handle100Continue :: IO ()
handle100Continue = Connection -> HttpVersion -> Maybe HeaderValue -> IO ()
handleExpect Connection
conn HttpVersion
httpversion Maybe HeaderValue
expect
(IO HeaderValue
rbody, Maybe (IORef Int)
remainingRef, RequestBodyLength
bodyLength) <- Source
-> IndexedHeader
-> IO (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
bodyAndSource Source
src IndexedHeader
idxhdr
IO HeaderValue
rbody' <- Maybe (IORef Int)
-> Handle -> IO HeaderValue -> IO () -> IO (IO HeaderValue)
timeoutBody Maybe (IORef Int)
remainingRef Handle
th IO HeaderValue
rbody IO ()
handle100Continue
IO HeaderValue
rbodyFlush <- Maybe (IORef Int)
-> Handle -> IO HeaderValue -> IO () -> IO (IO HeaderValue)
timeoutBody Maybe (IORef Int)
remainingRef Handle
th IO HeaderValue
rbody (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
let rawPath :: HeaderValue
rawPath = if Settings -> Bool
settingsNoParsePath Settings
settings then HeaderValue
unparsedPath else HeaderValue
path
vaultValue :: Vault
vaultValue =
Key (IO ()) -> IO () -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (IO ())
pauseTimeoutKey (Handle -> IO ()
Timeout.pause Handle
th)
(Vault -> Vault) -> (Vault -> Vault) -> Vault -> Vault
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key (FilePath -> IO FileInfo)
-> (FilePath -> IO FileInfo) -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (FilePath -> IO FileInfo)
getFileInfoKey (InternalInfo -> FilePath -> IO FileInfo
getFileInfo InternalInfo
ii)
#ifdef MIN_VERSION_crypton_x509
(Vault -> Vault) -> (Vault -> Vault) -> Vault -> Vault
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key (Maybe CertificateChain)
-> Maybe CertificateChain -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (Maybe CertificateChain)
getClientCertificateKey (Transport -> Maybe CertificateChain
getTransportClientCertificate Transport
transport)
#endif
(Vault -> Vault) -> Vault -> Vault
forall a b. (a -> b) -> a -> b
$ Vault
Vault.empty
req :: Request
req =
Request
{ requestMethod :: HeaderValue
requestMethod = HeaderValue
method
, httpVersion :: HttpVersion
httpVersion = HttpVersion
httpversion
, pathInfo :: [Text]
pathInfo = HeaderValue -> [Text]
H.decodePathSegments HeaderValue
path
, rawPathInfo :: HeaderValue
rawPathInfo = HeaderValue
rawPath
, rawQueryString :: HeaderValue
rawQueryString = HeaderValue
query
, queryString :: Query
queryString = HeaderValue -> Query
H.parseQuery HeaderValue
query
, requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
hdr
, isSecure :: Bool
isSecure = Transport -> Bool
isTransportSecure Transport
transport
, remoteHost :: SockAddr
remoteHost = SockAddr
addr
, requestBody :: IO HeaderValue
requestBody = IO HeaderValue
rbody'
, vault :: Vault
vault = Vault
vaultValue
, requestBodyLength :: RequestBodyLength
requestBodyLength = RequestBodyLength
bodyLength
, requestHeaderHost :: Maybe HeaderValue
requestHeaderHost = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqHost
, requestHeaderRange :: Maybe HeaderValue
requestHeaderRange = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqRange
, requestHeaderReferer :: Maybe HeaderValue
requestHeaderReferer = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqReferer
, requestHeaderUserAgent :: Maybe HeaderValue
requestHeaderUserAgent = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqUserAgent
}
(Request, Maybe (IORef Int), IndexedHeader, IO HeaderValue)
-> IO (Request, Maybe (IORef Int), IndexedHeader, IO HeaderValue)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, Maybe (IORef Int)
remainingRef, IndexedHeader
idxhdr, IO HeaderValue
rbodyFlush)
headerLines :: Int -> Bool -> Source -> IO [ByteString]
Int
maxTotalHeaderLength Bool
firstRequest Source
src = do
HeaderValue
bs <- Source -> IO HeaderValue
readSource Source
src
if HeaderValue -> Bool
S.null HeaderValue
bs
then
if Bool
firstRequest
then InvalidRequest -> IO [HeaderValue]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidRequest
ConnectionClosedByPeer
else NoKeepAliveRequest -> IO [HeaderValue]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO NoKeepAliveRequest
NoKeepAliveRequest
else Int -> Source -> THStatus -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src (Int -> Int -> BSEndoList -> BSEndo -> THStatus
THStatus Int
0 Int
0 BSEndoList
forall a. a -> a
id BSEndo
forall a. a -> a
id) HeaderValue
bs
data NoKeepAliveRequest = NoKeepAliveRequest
deriving (Int -> NoKeepAliveRequest -> ShowS
[NoKeepAliveRequest] -> ShowS
NoKeepAliveRequest -> FilePath
(Int -> NoKeepAliveRequest -> ShowS)
-> (NoKeepAliveRequest -> FilePath)
-> ([NoKeepAliveRequest] -> ShowS)
-> Show NoKeepAliveRequest
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoKeepAliveRequest -> ShowS
showsPrec :: Int -> NoKeepAliveRequest -> ShowS
$cshow :: NoKeepAliveRequest -> FilePath
show :: NoKeepAliveRequest -> FilePath
$cshowList :: [NoKeepAliveRequest] -> ShowS
showList :: [NoKeepAliveRequest] -> ShowS
Show, Typeable)
instance Exception NoKeepAliveRequest
handleExpect
:: Connection
-> H.HttpVersion
-> Maybe HeaderValue
-> IO ()
handleExpect :: Connection -> HttpVersion -> Maybe HeaderValue -> IO ()
handleExpect Connection
conn HttpVersion
ver (Just HeaderValue
"100-continue") = do
Connection -> HeaderValue -> IO ()
connSendAll Connection
conn HeaderValue
continue
IO ()
Conc.yield
where
continue :: HeaderValue
continue
| HttpVersion
ver HttpVersion -> HttpVersion -> Bool
forall a. Eq a => a -> a -> Bool
== HttpVersion
H.http11 = HeaderValue
"HTTP/1.1 100 Continue\r\n\r\n"
| Bool
otherwise = HeaderValue
"HTTP/1.0 100 Continue\r\n\r\n"
handleExpect Connection
_ HttpVersion
_ Maybe HeaderValue
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
bodyAndSource
:: Source
-> IndexedHeader
-> IO
( IO ByteString
, Maybe (I.IORef Int)
, RequestBodyLength
)
bodyAndSource :: Source
-> IndexedHeader
-> IO (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
bodyAndSource Source
src IndexedHeader
idxhdr
| Bool
chunked = do
CSource
csrc <- Source -> IO CSource
mkCSource Source
src
(IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
-> IO (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CSource -> IO HeaderValue
readCSource CSource
csrc, Maybe (IORef Int)
forall a. Maybe a
Nothing, RequestBodyLength
ChunkedBody)
| Bool
otherwise = do
let len :: Int
len = Maybe HeaderValue -> Int
toLength (Maybe HeaderValue -> Int) -> Maybe HeaderValue -> Int
forall a b. (a -> b) -> a -> b
$ IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqContentLength
bodyLen :: RequestBodyLength
bodyLen = Word64 -> RequestBodyLength
KnownLength (Word64 -> RequestBodyLength) -> Word64 -> RequestBodyLength
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
isrc :: ISource
isrc@(ISource Source
_ IORef Int
remaining) <- Source -> Int -> IO ISource
mkISource Source
src Int
len
(IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
-> IO (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ISource -> IO HeaderValue
readISource ISource
isrc, IORef Int -> Maybe (IORef Int)
forall a. a -> Maybe a
Just IORef Int
remaining, RequestBodyLength
bodyLen)
where
chunked :: Bool
chunked = Maybe HeaderValue -> Bool
isChunked (Maybe HeaderValue -> Bool) -> Maybe HeaderValue -> Bool
forall a b. (a -> b) -> a -> b
$ IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqTransferEncoding
toLength :: Maybe HeaderValue -> Int
toLength :: Maybe HeaderValue -> Int
toLength Maybe HeaderValue
Nothing = Int
0
toLength (Just HeaderValue
bs) = HeaderValue -> Int
forall a. Integral a => HeaderValue -> a
readInt HeaderValue
bs
isChunked :: Maybe HeaderValue -> Bool
isChunked :: Maybe HeaderValue -> Bool
isChunked (Just HeaderValue
bs) = BSEndo
forall s. FoldCase s => s -> s
CI.foldCase HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"chunked"
isChunked Maybe HeaderValue
_ = Bool
False
timeoutBody
:: Maybe (I.IORef Int)
-> Timeout.Handle
-> IO ByteString
-> IO ()
-> IO (IO ByteString)
timeoutBody :: Maybe (IORef Int)
-> Handle -> IO HeaderValue -> IO () -> IO (IO HeaderValue)
timeoutBody Maybe (IORef Int)
remainingRef Handle
timeoutHandle IO HeaderValue
rbody IO ()
handle100Continue = do
IORef Bool
isFirstRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
I.newIORef Bool
True
let checkEmpty :: HeaderValue -> IO Bool
checkEmpty =
case Maybe (IORef Int)
remainingRef of
Maybe (IORef Int)
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool)
-> (HeaderValue -> Bool) -> HeaderValue -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderValue -> Bool
S.null
Just IORef Int
ref -> \HeaderValue
bs ->
if HeaderValue -> Bool
S.null HeaderValue
bs
then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
Int
x <- IORef Int -> IO Int
forall a. IORef a -> IO a
I.readIORef IORef Int
ref
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
IO HeaderValue -> IO (IO HeaderValue)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO HeaderValue -> IO (IO HeaderValue))
-> IO HeaderValue -> IO (IO HeaderValue)
forall a b. (a -> b) -> a -> b
$ do
Bool
isFirst <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
I.readIORef IORef Bool
isFirstRef
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isFirst (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IO ()
handle100Continue
Handle -> IO ()
Timeout.resume Handle
timeoutHandle
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef Bool
isFirstRef Bool
False
HeaderValue
bs <- IO HeaderValue
rbody
Bool
isEmpty <- HeaderValue -> IO Bool
checkEmpty HeaderValue
bs
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isEmpty (Handle -> IO ()
Timeout.pause Handle
timeoutHandle)
HeaderValue -> IO HeaderValue
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HeaderValue
bs
type BSEndo = S.ByteString -> S.ByteString
type BSEndoList = [ByteString] -> [ByteString]
data THStatus
= THStatus
Int
Int
BSEndoList
BSEndo
push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]
push :: Int -> Source -> THStatus -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src (THStatus Int
totalLen Int
chunkLen BSEndoList
reqLines BSEndo
prepend) HeaderValue
bs
| Just Int
ix <- Word8 -> HeaderValue -> Maybe Int
S.elemIndex Word8
_lf HeaderValue
bs = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
currentTotal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxTotalHeaderLength) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InvalidRequest -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidRequest
OverLargeHeader
Int -> IO [HeaderValue]
newlineFound Int
ix
| Bool
otherwise = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
currentTotal Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bsLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxTotalHeaderLength) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InvalidRequest -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidRequest
OverLargeHeader
(HeaderValue -> IO [HeaderValue]) -> IO [HeaderValue]
forall a. (HeaderValue -> IO a) -> IO a
withNewChunk HeaderValue -> IO [HeaderValue]
noNewlineFound
where
bsLen :: Int
bsLen = HeaderValue -> Int
S.length HeaderValue
bs
currentTotal :: Int
currentTotal = Int
totalLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chunkLen
{-# INLINE withNewChunk #-}
withNewChunk :: (S.ByteString -> IO a) -> IO a
withNewChunk :: forall a. (HeaderValue -> IO a) -> IO a
withNewChunk HeaderValue -> IO a
f = do
HeaderValue
newChunk <- Source -> IO HeaderValue
readSource' Source
src
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HeaderValue -> Bool
S.null HeaderValue
newChunk) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InvalidRequest -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidRequest
IncompleteHeaders
HeaderValue -> IO a
f HeaderValue
newChunk
{-# INLINE noNewlineFound #-}
noNewlineFound :: HeaderValue -> IO [HeaderValue]
noNewlineFound HeaderValue
newChunk
| HeaderValue -> Word8
SU.unsafeLast HeaderValue
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_cr Bool -> Bool -> Bool
&& HasCallStack => HeaderValue -> Word8
HeaderValue -> Word8
S.head HeaderValue
newChunk Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_lf =
let bs' :: HeaderValue
bs' = Int -> BSEndo
SU.unsafeDrop Int
1 HeaderValue
newChunk
in if Int
bsLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int
chunkLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HeaderValue -> Bool
S.null HeaderValue
bs') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Source -> HeaderValue -> IO ()
leftoverSource Source
src HeaderValue
bs'
[HeaderValue] -> IO [HeaderValue]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HeaderValue] -> IO [HeaderValue])
-> [HeaderValue] -> IO [HeaderValue]
forall a b. (a -> b) -> a -> b
$ BSEndoList
reqLines []
else do
HeaderValue
rest <- if HeaderValue -> Bool
S.null HeaderValue
bs'
then (HeaderValue -> IO HeaderValue) -> IO HeaderValue
forall a. (HeaderValue -> IO a) -> IO a
withNewChunk HeaderValue -> IO HeaderValue
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
else HeaderValue -> IO HeaderValue
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeaderValue
bs'
let status :: THStatus
status = Int -> HeaderValue -> THStatus
addLine (Int
bsLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> BSEndo
SU.unsafeTake (Int
bsLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) HeaderValue
bs)
Int -> Source -> THStatus -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src THStatus
status HeaderValue
rest
| Bool
otherwise = do
let newChunkTotal :: Int
newChunkTotal = Int
chunkLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bsLen
newPrepend :: BSEndo
newPrepend = BSEndo
prepend BSEndo -> BSEndo -> BSEndo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderValue
bs HeaderValue -> BSEndo
forall a. Semigroup a => a -> a -> a
<>)
status :: THStatus
status = Int -> Int -> BSEndoList -> BSEndo -> THStatus
THStatus Int
totalLen Int
newChunkTotal BSEndoList
reqLines BSEndo
newPrepend
Int -> Source -> THStatus -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src THStatus
status HeaderValue
newChunk
{-# INLINE newlineFound #-}
newlineFound :: Int -> IO [HeaderValue]
newlineFound Int
ix
| Int
chunkLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Bool
startsWithLF = do
let rest :: HeaderValue
rest = Int -> BSEndo
SU.unsafeDrop Int
end HeaderValue
bs
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HeaderValue -> Bool
S.null HeaderValue
rest) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Source -> HeaderValue -> IO ()
leftoverSource Source
src HeaderValue
rest
[HeaderValue] -> IO [HeaderValue]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HeaderValue] -> IO [HeaderValue])
-> [HeaderValue] -> IO [HeaderValue]
forall a b. (a -> b) -> a -> b
$ BSEndoList
reqLines []
| Bool
otherwise = do
let p :: Int
p = Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
chunk :: Int
chunk =
if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& HeaderValue -> Int -> Word8
SU.unsafeIndex HeaderValue
bs Int
p Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_cr then Int
p else Int
ix
status :: THStatus
status = Int -> HeaderValue -> THStatus
addLine Int
end (Int -> BSEndo
SU.unsafeTake Int
chunk HeaderValue
bs)
continue :: HeaderValue -> IO [HeaderValue]
continue = Int -> Source -> THStatus -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src THStatus
status
if Int
end Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
bsLen
then (HeaderValue -> IO [HeaderValue]) -> IO [HeaderValue]
forall a. (HeaderValue -> IO a) -> IO a
withNewChunk HeaderValue -> IO [HeaderValue]
continue
else HeaderValue -> IO [HeaderValue]
continue (HeaderValue -> IO [HeaderValue])
-> HeaderValue -> IO [HeaderValue]
forall a b. (a -> b) -> a -> b
$ Int -> BSEndo
SU.unsafeDrop Int
end HeaderValue
bs
where
end :: Int
end = Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
startsWithLF :: Bool
startsWithLF =
case Int
ix of
Int
0 -> Bool
True
Int
1 -> HeaderValue -> Word8
SU.unsafeHead HeaderValue
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_cr
Int
_ -> Bool
False
{-# INLINE addLine #-}
addLine :: Int -> HeaderValue -> THStatus
addLine Int
len HeaderValue
chunk =
let newTotal :: Int
newTotal = Int
currentTotal Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len
newLine :: HeaderValue
newLine =
if Int
chunkLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then HeaderValue
chunk else BSEndo
prepend HeaderValue
chunk
in Int -> Int -> BSEndoList -> BSEndo -> THStatus
THStatus Int
newTotal Int
0 (BSEndoList
reqLines BSEndoList -> BSEndoList -> BSEndoList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderValue
newLineHeaderValue -> BSEndoList
forall a. a -> [a] -> [a]
:)) BSEndo
forall a. a -> a
id
pauseTimeoutKey :: Vault.Key (IO ())
pauseTimeoutKey :: Key (IO ())
pauseTimeoutKey = IO (Key (IO ())) -> Key (IO ())
forall a. IO a -> a
unsafePerformIO IO (Key (IO ()))
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE pauseTimeoutKey #-}
getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)
getFileInfoKey :: Key (FilePath -> IO FileInfo)
getFileInfoKey = IO (Key (FilePath -> IO FileInfo)) -> Key (FilePath -> IO FileInfo)
forall a. IO a -> a
unsafePerformIO IO (Key (FilePath -> IO FileInfo))
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE getFileInfoKey #-}
#ifdef MIN_VERSION_crypton_x509
getClientCertificateKey :: Vault.Key (Maybe CertificateChain)
getClientCertificateKey :: Key (Maybe CertificateChain)
getClientCertificateKey = IO (Key (Maybe CertificateChain)) -> Key (Maybe CertificateChain)
forall a. IO a -> a
unsafePerformIO IO (Key (Maybe CertificateChain))
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE getClientCertificateKey #-}
#endif