{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE UnboxedTuples #-}
module Snap.Internal.Http.Server.Parser
( IRequest(..)
, HttpParseException(..)
, readChunkedTransferEncoding
, writeChunkedTransferEncoding
, parseRequest
, parseFromStream
, parseCookie
, parseUrlEncoded
, getStdContentLength
, getStdHost
, getStdTransferEncoding
, getStdCookie
, getStdContentType
, getStdConnection
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Exception (Exception, throwIO)
import Control.Monad (void, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Attoparsec.ByteString.Char8 (Parser, hexadecimal, takeTill)
import qualified Data.ByteString.Char8 as S
import Data.ByteString.Internal (ByteString (..), c2w, memchr, w2c)
#if MIN_VERSION_bytestring(0, 10, 6)
import Data.ByteString.Internal (accursedUnutterablePerformIO)
#else
import Data.ByteString.Internal (inlinePerformIO)
#endif
import qualified Data.ByteString.Unsafe as S
import Data.List (sort)
import Data.Typeable (Typeable)
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr (minusPtr, nullPtr, plusPtr)
import Prelude hiding (take)
import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)
import Data.ByteString.Builder (Builder)
import System.IO.Streams (InputStream, OutputStream, Generator)
import qualified System.IO.Streams as Streams
import System.IO.Streams.Attoparsec (parseFromStream)
import Snap.Internal.Http.Types (Method (..))
import Snap.Internal.Parsing (crlf, parseCookie, parseUrlEncoded, unsafeFromNat)
import Snap.Types.Headers (Headers)
import qualified Snap.Types.Headers as H
newtype StandardHeaders = StandardHeaders (V.Vector (Maybe ByteString))
type MStandardHeaders = MV.IOVector (Maybe ByteString)
contentLengthTag, hostTag, transferEncodingTag, cookieTag, contentTypeTag,
connectionTag, nStandardHeaders :: Int
contentLengthTag :: Int
contentLengthTag = Int
0
hostTag :: Int
hostTag = Int
1
transferEncodingTag :: Int
transferEncodingTag = Int
2
cookieTag :: Int
cookieTag = Int
3
contentTypeTag :: Int
contentTypeTag = Int
4
connectionTag :: Int
connectionTag = Int
5
nStandardHeaders :: Int
nStandardHeaders = Int
6
findStdHeaderIndex :: ByteString -> Int
ByteString
"content-length" = Int
contentLengthTag
findStdHeaderIndex ByteString
"host" = Int
hostTag
findStdHeaderIndex ByteString
"transfer-encoding" = Int
transferEncodingTag
findStdHeaderIndex ByteString
"cookie" = Int
cookieTag
findStdHeaderIndex ByteString
"content-type" = Int
contentTypeTag
findStdHeaderIndex ByteString
"connection" = Int
connectionTag
findStdHeaderIndex ByteString
_ = -Int
1
getStdContentLength, getStdHost, getStdTransferEncoding, getStdCookie,
getStdConnection, getStdContentType :: StandardHeaders -> Maybe ByteString
getStdContentLength :: StandardHeaders -> Maybe ByteString
getStdContentLength (StandardHeaders Vector (Maybe ByteString)
v) = Vector (Maybe ByteString) -> Int -> Maybe ByteString
forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
contentLengthTag
getStdHost :: StandardHeaders -> Maybe ByteString
getStdHost (StandardHeaders Vector (Maybe ByteString)
v) = Vector (Maybe ByteString) -> Int -> Maybe ByteString
forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
hostTag
getStdTransferEncoding :: StandardHeaders -> Maybe ByteString
getStdTransferEncoding (StandardHeaders Vector (Maybe ByteString)
v) = Vector (Maybe ByteString) -> Int -> Maybe ByteString
forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
transferEncodingTag
getStdCookie :: StandardHeaders -> Maybe ByteString
getStdCookie (StandardHeaders Vector (Maybe ByteString)
v) = Vector (Maybe ByteString) -> Int -> Maybe ByteString
forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
cookieTag
getStdContentType :: StandardHeaders -> Maybe ByteString
getStdContentType (StandardHeaders Vector (Maybe ByteString)
v) = Vector (Maybe ByteString) -> Int -> Maybe ByteString
forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
contentTypeTag
getStdConnection :: StandardHeaders -> Maybe ByteString
getStdConnection (StandardHeaders Vector (Maybe ByteString)
v) = Vector (Maybe ByteString) -> Int -> Maybe ByteString
forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
connectionTag
newMStandardHeaders :: IO MStandardHeaders
newMStandardHeaders :: IO MStandardHeaders
newMStandardHeaders = Int
-> Maybe ByteString
-> IO (MVector (PrimState IO) (Maybe ByteString))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
MV.replicate Int
nStandardHeaders Maybe ByteString
forall a. Maybe a
Nothing
data IRequest = IRequest
{ IRequest -> Method
iMethod :: !Method
, IRequest -> ByteString
iRequestUri :: !ByteString
, IRequest -> (Int, Int)
iHttpVersion :: (Int, Int)
, :: Headers
, :: StandardHeaders
}
instance Eq IRequest where
IRequest
a == :: IRequest -> IRequest -> Bool
== IRequest
b =
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ IRequest -> Method
iMethod IRequest
a Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== IRequest -> Method
iMethod IRequest
b
, IRequest -> ByteString
iRequestUri IRequest
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== IRequest -> ByteString
iRequestUri IRequest
b
, IRequest -> (Int, Int)
iHttpVersion IRequest
a (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== IRequest -> (Int, Int)
iHttpVersion IRequest
b
, [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. Ord a => [a] -> [a]
sort (Headers -> [(CI ByteString, ByteString)]
H.toList (IRequest -> Headers
iRequestHeaders IRequest
a))
[(CI ByteString, ByteString)]
-> [(CI ByteString, ByteString)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. Ord a => [a] -> [a]
sort (Headers -> [(CI ByteString, ByteString)]
H.toList (IRequest -> Headers
iRequestHeaders IRequest
b))
]
instance Show IRequest where
show :: IRequest -> String
show (IRequest Method
m ByteString
u (Int
major, Int
minor) Headers
hdrs StandardHeaders
_) =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Method -> String
forall a. Show a => a -> String
show Method
m
, String
" "
, ByteString -> String
forall a. Show a => a -> String
show ByteString
u
, String
" "
, Int -> String
forall a. Show a => a -> String
show Int
major
, String
"."
, Int -> String
forall a. Show a => a -> String
show Int
minor
, String
" "
, Headers -> String
forall a. Show a => a -> String
show Headers
hdrs
]
data HttpParseException = HttpParseException String deriving (Typeable, Int -> HttpParseException -> ShowS
[HttpParseException] -> ShowS
HttpParseException -> String
(Int -> HttpParseException -> ShowS)
-> (HttpParseException -> String)
-> ([HttpParseException] -> ShowS)
-> Show HttpParseException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HttpParseException] -> ShowS
$cshowList :: [HttpParseException] -> ShowS
show :: HttpParseException -> String
$cshow :: HttpParseException -> String
showsPrec :: Int -> HttpParseException -> ShowS
$cshowsPrec :: Int -> HttpParseException -> ShowS
Show)
instance Exception HttpParseException
{-# INLINE parseRequest #-}
parseRequest :: InputStream ByteString -> IO IRequest
parseRequest :: InputStream ByteString -> IO IRequest
parseRequest InputStream ByteString
input = do
ByteString
line <- InputStream ByteString -> IO ByteString
pLine InputStream ByteString
input
let (!ByteString
mStr, !ByteString
s) = ByteString -> (ByteString, ByteString)
bSp ByteString
line
let (!ByteString
uri, !ByteString
vStr) = ByteString -> (ByteString, ByteString)
bSp ByteString
s
let method :: Method
method = ByteString -> Method
methodFromString ByteString
mStr
let !version :: (Int, Int)
version = ByteString -> (Int, Int)
forall a b.
(Enum a, Enum b, Num a, Num b, Bits a, Bits b) =>
ByteString -> (a, b)
pVer ByteString
vStr
let (Maybe ByteString
host, ByteString
uri') = ByteString -> (Maybe ByteString, ByteString)
getHost ByteString
uri
let uri'' :: ByteString
uri'' = if ByteString -> Bool
S.null ByteString
uri' then ByteString
"/" else ByteString
uri'
MStandardHeaders
stdHdrs <- IO MStandardHeaders
newMStandardHeaders
MVector (PrimState IO) (Maybe ByteString)
-> Int -> Maybe ByteString -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.unsafeWrite MStandardHeaders
MVector (PrimState IO) (Maybe ByteString)
stdHdrs Int
hostTag Maybe ByteString
host
Headers
hdrs <- MStandardHeaders -> InputStream ByteString -> IO Headers
pHeaders MStandardHeaders
stdHdrs InputStream ByteString
input
StandardHeaders
outStd <- Vector (Maybe ByteString) -> StandardHeaders
StandardHeaders (Vector (Maybe ByteString) -> StandardHeaders)
-> IO (Vector (Maybe ByteString)) -> IO StandardHeaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) (Maybe ByteString)
-> IO (Vector (Maybe ByteString))
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MStandardHeaders
MVector (PrimState IO) (Maybe ByteString)
stdHdrs
IRequest -> IO IRequest
forall (m :: * -> *) a. Monad m => a -> m a
return (IRequest -> IO IRequest) -> IRequest -> IO IRequest
forall a b. (a -> b) -> a -> b
$! Method
-> ByteString
-> (Int, Int)
-> Headers
-> StandardHeaders
-> IRequest
IRequest Method
method ByteString
uri'' (Int, Int)
version Headers
hdrs StandardHeaders
outStd
where
getHost :: ByteString -> (Maybe ByteString, ByteString)
getHost ByteString
s | ByteString
"http://" ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
s
= let s' :: ByteString
s' = Int -> ByteString -> ByteString
S.unsafeDrop Int
7 ByteString
s
(!ByteString
host, !ByteString
uri) = Char -> ByteString -> (ByteString, ByteString)
breakCh Char
'/' ByteString
s'
in (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$! ByteString
host, ByteString
uri)
| ByteString
"https://" ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
s
= let s' :: ByteString
s' = Int -> ByteString -> ByteString
S.unsafeDrop Int
8 ByteString
s
(!ByteString
host, !ByteString
uri) = Char -> ByteString -> (ByteString, ByteString)
breakCh Char
'/' ByteString
s'
in (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$! ByteString
host, ByteString
uri)
| Bool
otherwise = (Maybe ByteString
forall a. Maybe a
Nothing, ByteString
s)
pVer :: ByteString -> (a, b)
pVer ByteString
s = if ByteString
"HTTP/" ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
s
then ByteString -> (a, b)
forall a b.
(Enum a, Num a, Bits a, Enum b, Num b, Bits b) =>
ByteString -> (a, b)
pVers (Int -> ByteString -> ByteString
S.unsafeDrop Int
5 ByteString
s)
else (a
1, b
0)
bSp :: ByteString -> (ByteString, ByteString)
bSp = Char -> ByteString -> (ByteString, ByteString)
splitCh Char
' '
pVers :: ByteString -> (a, b)
pVers ByteString
s = (a
c, b
d)
where
(!ByteString
a, !ByteString
b) = Char -> ByteString -> (ByteString, ByteString)
splitCh Char
'.' ByteString
s
!c :: a
c = ByteString -> a
forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat ByteString
a
!d :: b
d = ByteString -> b
forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat ByteString
b
pLine :: InputStream ByteString -> IO ByteString
pLine :: InputStream ByteString -> IO ByteString
pLine InputStream ByteString
input = [ByteString] -> IO ByteString
go []
where
throwNoCRLF :: IO a
throwNoCRLF =
HttpParseException -> IO a
forall e a. Exception e => e -> IO a
throwIO (HttpParseException -> IO a) -> HttpParseException -> IO a
forall a b. (a -> b) -> a -> b
$
String -> HttpParseException
HttpParseException String
"parse error: expected line ending in crlf"
throwBadCRLF :: IO a
throwBadCRLF =
HttpParseException -> IO a
forall e a. Exception e => e -> IO a
throwIO (HttpParseException -> IO a) -> HttpParseException -> IO a
forall a b. (a -> b) -> a -> b
$
String -> HttpParseException
HttpParseException String
"parse error: got cr without subsequent lf"
go :: [ByteString] -> IO ByteString
go ![ByteString]
l = do
!Maybe ByteString
mb <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input
!ByteString
s <- IO ByteString
-> (ByteString -> IO ByteString)
-> Maybe ByteString
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ByteString
forall a. IO a
throwNoCRLF ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
mb
let !i :: Int
i = Char -> ByteString -> Int
elemIndex Char
'\r' ByteString
s
if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
then [ByteString] -> ByteString -> IO ByteString
noCRLF [ByteString]
l ByteString
s
else case () of
!()
_ | Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= ByteString -> Int
S.length ByteString
s -> [ByteString] -> ByteString -> Int -> IO ByteString
lastIsCR [ByteString]
l ByteString
s Int
i
| ByteString -> Int -> Word8
S.unsafeIndex ByteString
s (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
10 -> [ByteString] -> ByteString -> Int -> IO ByteString
foundCRLF [ByteString]
l ByteString
s Int
i
| Bool
otherwise -> IO ByteString
forall a. IO a
throwBadCRLF
foundCRLF :: [ByteString] -> ByteString -> Int -> IO ByteString
foundCRLF [ByteString]
l ByteString
s !Int
i1 = do
let !i2 :: Int
i2 = Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
let !a :: ByteString
a = Int -> ByteString -> ByteString
S.unsafeTake Int
i1 ByteString
s
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ByteString -> Int
S.length ByteString
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let !b :: ByteString
b = Int -> ByteString -> ByteString
S.unsafeDrop Int
i2 ByteString
s
ByteString -> InputStream ByteString -> IO ()
forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
b InputStream ByteString
input
let !out :: ByteString
out = if [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
l then ByteString
a else [ByteString] -> ByteString
S.concat ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (ByteString
aByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
l))
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out
noCRLF :: [ByteString] -> ByteString -> IO ByteString
noCRLF [ByteString]
l ByteString
s = [ByteString] -> IO ByteString
go (ByteString
sByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
l)
lastIsCR :: [ByteString] -> ByteString -> Int -> IO ByteString
lastIsCR [ByteString]
l ByteString
s !Int
idx = do
!ByteString
t <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input IO (Maybe ByteString)
-> (Maybe ByteString -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO ByteString
-> (ByteString -> IO ByteString)
-> Maybe ByteString
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ByteString
forall a. IO a
throwNoCRLF ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
if ByteString -> Bool
S.null ByteString
t
then [ByteString] -> ByteString -> Int -> IO ByteString
lastIsCR [ByteString]
l ByteString
s Int
idx
else do
let !c :: Word8
c = ByteString -> Word8
S.unsafeHead ByteString
t
if Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
10
then IO ByteString
forall a. IO a
throwBadCRLF
else do
let !a :: ByteString
a = Int -> ByteString -> ByteString
S.unsafeTake Int
idx ByteString
s
let !b :: ByteString
b = Int -> ByteString -> ByteString
S.unsafeDrop Int
1 ByteString
t
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
$ ByteString -> Bool
S.null ByteString
b) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> InputStream ByteString -> IO ()
forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
b InputStream ByteString
input
let !out :: ByteString
out = if [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
l then ByteString
a else [ByteString] -> ByteString
S.concat ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (ByteString
aByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
l))
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out
splitCh :: Char -> ByteString -> (ByteString, ByteString)
splitCh :: Char -> ByteString -> (ByteString, ByteString)
splitCh !Char
c !ByteString
s = if Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
then (ByteString
s, ByteString
S.empty)
else let !a :: ByteString
a = Int -> ByteString -> ByteString
S.unsafeTake Int
idx ByteString
s
!b :: ByteString
b = Int -> ByteString -> ByteString
S.unsafeDrop (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
s
in (ByteString
a, ByteString
b)
where
!idx :: Int
idx = Char -> ByteString -> Int
elemIndex Char
c ByteString
s
{-# INLINE splitCh #-}
breakCh :: Char -> ByteString -> (ByteString, ByteString)
breakCh :: Char -> ByteString -> (ByteString, ByteString)
breakCh !Char
c !ByteString
s = if Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
then (ByteString
s, ByteString
S.empty)
else let !a :: ByteString
a = Int -> ByteString -> ByteString
S.unsafeTake Int
idx ByteString
s
!b :: ByteString
b = Int -> ByteString -> ByteString
S.unsafeDrop Int
idx ByteString
s
in (ByteString
a, ByteString
b)
where
!idx :: Int
idx = Char -> ByteString -> Int
elemIndex Char
c ByteString
s
{-# INLINE breakCh #-}
splitHeader :: ByteString -> (ByteString, ByteString)
!ByteString
s = if Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
then (ByteString
s, ByteString
S.empty)
else let !a :: ByteString
a = Int -> ByteString -> ByteString
S.unsafeTake Int
idx ByteString
s
in (ByteString
a, Int -> ByteString
skipSp (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
where
!idx :: Int
idx = Char -> ByteString -> Int
elemIndex Char
':' ByteString
s
l :: Int
l = ByteString -> Int
S.length ByteString
s
skipSp :: Int -> ByteString
skipSp !Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
l = ByteString
S.empty
| Bool
otherwise = let c :: Word8
c = ByteString -> Int -> Word8
S.unsafeIndex ByteString
s Int
i
in if Char -> Bool
isLWS (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Word8 -> Char
w2c Word8
c
then Int -> ByteString
skipSp (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
else Int -> ByteString -> ByteString
S.unsafeDrop Int
i ByteString
s
{-# INLINE splitHeader #-}
isLWS :: Char -> Bool
isLWS :: Char -> Bool
isLWS Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'
{-# INLINE isLWS #-}
pHeaders :: MStandardHeaders -> InputStream ByteString -> IO Headers
MStandardHeaders
stdHdrs InputStream ByteString
input = do
Headers
hdrs <- [(ByteString, ByteString)] -> Headers
H.unsafeFromCaseFoldedList ([(ByteString, ByteString)] -> Headers)
-> IO [(ByteString, ByteString)] -> IO Headers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ByteString, ByteString)] -> IO [(ByteString, ByteString)]
go []
Headers -> IO Headers
forall (m :: * -> *) a. Monad m => a -> m a
return Headers
hdrs
where
go :: [(ByteString, ByteString)] -> IO [(ByteString, ByteString)]
go ![(ByteString, ByteString)]
list = do
ByteString
line <- InputStream ByteString -> IO ByteString
pLine InputStream ByteString
input
if ByteString -> Bool
S.null ByteString
line
then [(ByteString, ByteString)] -> IO [(ByteString, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(ByteString, ByteString)]
list
else do
let (!ByteString
k0,!ByteString
v) = ByteString -> (ByteString, ByteString)
splitHeader ByteString
line
let !k :: ByteString
k = ByteString -> ByteString
toLower ByteString
k0
[ByteString] -> [ByteString]
vf <- ([ByteString] -> [ByteString]) -> IO ([ByteString] -> [ByteString])
forall c. ([ByteString] -> c) -> IO ([ByteString] -> c)
pCont [ByteString] -> [ByteString]
forall a. a -> a
id
let vs :: [ByteString]
vs = [ByteString] -> [ByteString]
vf []
let !v' :: ByteString
v' = [ByteString] -> ByteString
S.concat (ByteString
vByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
vs)
let idx :: Int
idx = ByteString -> Int
findStdHeaderIndex ByteString
k
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) (Maybe ByteString)
-> Int -> Maybe ByteString -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.unsafeWrite MStandardHeaders
MVector (PrimState IO) (Maybe ByteString)
stdHdrs Int
idx (Maybe ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$! ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
v'
let l' :: [(ByteString, ByteString)]
l' = ((ByteString
k, ByteString
v')(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:[(ByteString, ByteString)]
list)
[(ByteString, ByteString)] -> IO [(ByteString, ByteString)]
go [(ByteString, ByteString)]
l'
trimBegin :: ByteString -> ByteString
trimBegin = (Char -> Bool) -> ByteString -> ByteString
S.dropWhile Char -> Bool
isLWS
pCont :: ([ByteString] -> c) -> IO ([ByteString] -> c)
pCont ![ByteString] -> c
dlist = do
Maybe ByteString
mbS <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.peek InputStream ByteString
input
IO ([ByteString] -> c)
-> (ByteString -> IO ([ByteString] -> c))
-> Maybe ByteString
-> IO ([ByteString] -> c)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (([ByteString] -> c) -> IO ([ByteString] -> c)
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString] -> c
dlist)
(\ByteString
s -> if Bool -> Bool
not (ByteString -> Bool
S.null ByteString
s)
then if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isLWS (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Word8 -> Char
w2c (Word8 -> Char) -> Word8 -> Char
forall a b. (a -> b) -> a -> b
$ ByteString -> Word8
S.unsafeHead ByteString
s
then ([ByteString] -> c) -> IO ([ByteString] -> c)
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString] -> c
dlist
else ([ByteString] -> c) -> IO ([ByteString] -> c)
procCont [ByteString] -> c
dlist
else InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input IO (Maybe ByteString)
-> IO ([ByteString] -> c) -> IO ([ByteString] -> c)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ([ByteString] -> c) -> IO ([ByteString] -> c)
pCont [ByteString] -> c
dlist)
Maybe ByteString
mbS
procCont :: ([ByteString] -> c) -> IO ([ByteString] -> c)
procCont ![ByteString] -> c
dlist = do
ByteString
line <- InputStream ByteString -> IO ByteString
pLine InputStream ByteString
input
let !t :: ByteString
t = ByteString -> ByteString
trimBegin ByteString
line
([ByteString] -> c) -> IO ([ByteString] -> c)
pCont ([ByteString] -> c
dlist ([ByteString] -> c)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
" "ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
tByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:))
methodFromString :: ByteString -> Method
methodFromString :: ByteString -> Method
methodFromString ByteString
"GET" = Method
GET
methodFromString ByteString
"POST" = Method
POST
methodFromString ByteString
"HEAD" = Method
HEAD
methodFromString ByteString
"PUT" = Method
PUT
methodFromString ByteString
"DELETE" = Method
DELETE
methodFromString ByteString
"TRACE" = Method
TRACE
methodFromString ByteString
"OPTIONS" = Method
OPTIONS
methodFromString ByteString
"CONNECT" = Method
CONNECT
methodFromString ByteString
"PATCH" = Method
PATCH
methodFromString ByteString
s = ByteString -> Method
Method ByteString
s
readChunkedTransferEncoding :: InputStream ByteString
-> IO (InputStream ByteString)
readChunkedTransferEncoding :: InputStream ByteString -> IO (InputStream ByteString)
readChunkedTransferEncoding InputStream ByteString
input =
Generator ByteString () -> IO (InputStream ByteString)
forall r a. Generator r a -> IO (InputStream r)
Streams.fromGenerator (InputStream ByteString -> Generator ByteString ()
consumeChunks InputStream ByteString
input)
writeChunkedTransferEncoding :: OutputStream Builder
-> IO (OutputStream Builder)
writeChunkedTransferEncoding :: OutputStream Builder -> IO (OutputStream Builder)
writeChunkedTransferEncoding OutputStream Builder
os = (Maybe Builder -> IO ()) -> IO (OutputStream Builder)
forall a. (Maybe a -> IO ()) -> IO (OutputStream a)
Streams.makeOutputStream Maybe Builder -> IO ()
f
where
f :: Maybe Builder -> IO ()
f Maybe Builder
Nothing = do
Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
chunkedTransferTerminator) OutputStream Builder
os
Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write Maybe Builder
forall a. Maybe a
Nothing OutputStream Builder
os
f Maybe Builder
x = Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Builder
chunkedTransferEncoding (Builder -> Builder) -> Maybe Builder -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe Builder
x) OutputStream Builder
os
consumeChunks :: InputStream ByteString -> Generator ByteString ()
consumeChunks :: InputStream ByteString -> Generator ByteString ()
consumeChunks InputStream ByteString
i1 = do
!Int
n <- Generator ByteString Int
parseSize
if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then do
Int -> Generator ByteString ()
go Int
n
Generator ByteString ()
skipCRLF
InputStream ByteString -> Generator ByteString ()
consumeChunks InputStream ByteString
i1
else do
Generator ByteString ()
skipCRLF
where
go :: Int -> Generator ByteString ()
go Int
0 = () -> Generator ByteString ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go !Int
n = do
(!ByteString
x',!Int
r) <- IO (ByteString, Int) -> Generator ByteString (ByteString, Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ByteString, Int) -> Generator ByteString (ByteString, Int))
-> IO (ByteString, Int) -> Generator ByteString (ByteString, Int)
forall a b. (a -> b) -> a -> b
$ Int -> InputStream ByteString -> IO (ByteString, Int)
readN Int
n InputStream ByteString
i1
ByteString -> Generator ByteString ()
forall r. r -> Generator r ()
Streams.yield ByteString
x'
Int -> Generator ByteString ()
go Int
r
parseSize :: Generator ByteString Int
parseSize = do
IO Int -> Generator ByteString Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> Generator ByteString Int)
-> IO Int -> Generator ByteString Int
forall a b. (a -> b) -> a -> b
$ Parser Int -> InputStream ByteString -> IO Int
forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream Parser Int
transferChunkSize InputStream ByteString
i1
skipCRLF :: Generator ByteString ()
skipCRLF = do
IO () -> Generator ByteString ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Generator ByteString ())
-> IO () -> Generator ByteString ()
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString -> InputStream ByteString -> IO ByteString
forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream Parser ByteString
crlf InputStream ByteString
i1)
transferChunkSize :: Parser (Int)
transferChunkSize :: Parser Int
transferChunkSize = do
!Int
n <- Parser Int
forall a. (Integral a, Bits a) => Parser a
hexadecimal
Parser ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Char -> Bool) -> Parser ByteString
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'))
Parser ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString
crlf
Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
bUFSIZ :: Int
bUFSIZ :: Int
bUFSIZ = Int
32752
readN :: Int -> InputStream ByteString -> IO (ByteString, Int)
readN :: Int -> InputStream ByteString -> IO (ByteString, Int)
readN Int
n InputStream ByteString
input = do
!ByteString
x' <- Int -> InputStream ByteString -> IO ByteString
Streams.readExactly Int
p InputStream ByteString
input
(ByteString, Int) -> IO (ByteString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
x', Int
r)
where
!d :: Int
d = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bUFSIZ
!p :: Int
p = if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int
bUFSIZ else Int
n
!r :: Int
r = if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int
d else Int
0
toLower :: ByteString -> ByteString
toLower :: ByteString -> ByteString
toLower = (Char -> Char) -> ByteString -> ByteString
S.map Char -> Char
lower
where
lower :: Char -> Char
lower Char
c0 = let !c :: Word8
c = Char -> Word8
c2w Char
c0
in if Word8
65 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
90
then Word8 -> Char
w2c (Word8 -> Char) -> Word8 -> Char
forall a b. (a -> b) -> a -> b
$! Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
32
else Char
c0
elemIndex :: Char -> ByteString -> Int
#if MIN_VERSION_bytestring(0, 10, 6)
elemIndex :: Char -> ByteString -> Int
elemIndex Char
c (PS !ForeignPtr Word8
fp !Int
start !Int
len) = IO Int -> Int
forall a. IO a -> a
accursedUnutterablePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$
#else
elemIndex c (PS !fp !start !len) = inlinePerformIO $
#endif
ForeignPtr Word8 -> (Ptr Word8 -> IO Int) -> IO Int
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO Int) -> IO Int)
-> (Ptr Word8 -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p0 -> do
let !p :: Ptr b
p = Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
p0 Int
start
Ptr Word8
q <- Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
memchr Ptr Word8
forall b. Ptr b
p Word8
w8 (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$! if Ptr Word8
q Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
forall b. Ptr b
nullPtr then (-Int
1) else Ptr Word8
q Ptr Word8 -> Ptr Any -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Any
forall b. Ptr b
p
where
!w8 :: Word8
w8 = Char -> Word8
c2w Char
c
{-# INLINE elemIndex #-}