{-# 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 qualified Control.Exception as E
import Control.Monad (void, when)
import Data.Attoparsec.ByteString.Char8 (Parser, hexadecimal, skipWhile, take)
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
#if !MIN_VERSION_io_streams(1,2,0)
import Data.IORef (newIORef, readIORef, writeIORef)
#endif
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)
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 = 0
hostTag :: Int
hostTag = 1
transferEncodingTag :: Int
transferEncodingTag = 2
cookieTag :: Int
cookieTag = 3
contentTypeTag :: Int
contentTypeTag = 4
connectionTag :: Int
connectionTag = 5
nStandardHeaders :: Int
nStandardHeaders = 6
findStdHeaderIndex :: ByteString -> Int
"content-length" = Int
contentLengthTag
findStdHeaderIndex "host" = Int
hostTag
findStdHeaderIndex "transfer-encoding" = Int
transferEncodingTag
findStdHeaderIndex "cookie" = Int
cookieTag
findStdHeaderIndex "content-type" = Int
contentTypeTag
findStdHeaderIndex "connection" = Int
connectionTag
findStdHeaderIndex _ = -1
getStdContentLength, getStdHost, getStdTransferEncoding, getStdCookie,
getStdConnection, getStdContentType :: StandardHeaders -> Maybe ByteString
getStdContentLength :: StandardHeaders -> Maybe ByteString
getStdContentLength (StandardHeaders v :: 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 v :: 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 v :: 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 v :: 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 v :: 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 v :: 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
a :: IRequest
a == :: IRequest -> IRequest -> Bool
== b :: 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 m :: Method
m u :: ByteString
u (major :: Int
major, minor :: Int
minor) hdrs :: Headers
hdrs _) =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Method -> String
forall a. Show a => a -> String
show Method
m
, " "
, ByteString -> String
forall a. Show a => a -> String
show ByteString
u
, " "
, Int -> String
forall a. Show a => a -> String
show Int
major
, "."
, Int -> String
forall a. Show a => a -> String
show Int
minor
, " "
, 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 input :: 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 (host :: Maybe ByteString
host, uri' :: ByteString
uri') = ByteString -> (Maybe ByteString, ByteString)
getHost ByteString
uri
let uri'' :: ByteString
uri'' = if ByteString -> Bool
S.null ByteString
uri' then "/" 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 s :: ByteString
s | "http://" ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
s
= let s' :: ByteString
s' = Int -> ByteString -> ByteString
S.unsafeDrop 7 ByteString
s
(!ByteString
host, !ByteString
uri) = Char -> ByteString -> (ByteString, ByteString)
breakCh '/' 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)
| "https://" ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
s
= let s' :: ByteString
s' = Int -> ByteString -> ByteString
S.unsafeDrop 8 ByteString
s
(!ByteString
host, !ByteString
uri) = Char -> ByteString -> (ByteString, ByteString)
breakCh '/' 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 s :: ByteString
s = if "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 5 ByteString
s)
else (1, 0)
bSp :: ByteString -> (ByteString, ByteString)
bSp = Char -> ByteString -> (ByteString, ByteString)
splitCh ' '
pVers :: ByteString -> (a, b)
pVers s :: ByteString
s = (a
c, b
d)
where
(!ByteString
a, !ByteString
b) = Char -> ByteString -> (ByteString, ByteString)
splitCh '.' 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 input :: 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 "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 "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 '\r' ByteString
s
if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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
+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
+1) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 l :: [ByteString]
l s :: ByteString
s !Int
i1 = do
let !i2 :: Int
i2 = Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 l :: [ByteString]
l s :: ByteString
s = [ByteString] -> IO ByteString
go (ByteString
sByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
l)
lastIsCR :: [ByteString] -> ByteString -> Int -> IO ByteString
lastIsCR l :: [ByteString]
l s :: 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
/= 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 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
< 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
+ 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
< 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
< 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
+ 1))
where
!idx :: Int
idx = Char -> ByteString -> Int
elemIndex ':' 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
+ 1
else Int -> ByteString -> ByteString
S.unsafeDrop Int
i ByteString
s
{-# INLINE splitHeader #-}
isLWS :: Char -> Bool
isLWS :: Char -> Bool
isLWS c :: Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\t'
{-# INLINE isLWS #-}
pHeaders :: MStandardHeaders -> InputStream ByteString -> IO Headers
stdHdrs :: MStandardHeaders
stdHdrs input :: 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
>= 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)
(\s :: 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]
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 "GET" = Method
GET
methodFromString "POST" = Method
POST
methodFromString "HEAD" = Method
HEAD
methodFromString "PUT" = Method
PUT
methodFromString "DELETE" = Method
DELETE
methodFromString "TRACE" = Method
TRACE
methodFromString "OPTIONS" = Method
OPTIONS
methodFromString "CONNECT" = Method
CONNECT
methodFromString "PATCH" = Method
PATCH
methodFromString s :: ByteString
s = ByteString -> Method
Method ByteString
s
readChunkedTransferEncoding :: InputStream ByteString
-> IO (InputStream ByteString)
readChunkedTransferEncoding :: InputStream ByteString -> IO (InputStream ByteString)
readChunkedTransferEncoding input :: InputStream ByteString
input =
IO (Maybe ByteString) -> IO (InputStream ByteString)
forall a. IO (Maybe a) -> IO (InputStream a)
Streams.makeInputStream (IO (Maybe ByteString) -> IO (InputStream ByteString))
-> IO (Maybe ByteString) -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ Parser (Maybe ByteString)
-> InputStream ByteString -> IO (Maybe ByteString)
forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream Parser (Maybe ByteString)
pGetTransferChunk InputStream ByteString
input
writeChunkedTransferEncoding :: OutputStream Builder
-> IO (OutputStream Builder)
#if MIN_VERSION_io_streams(1,2,0)
writeChunkedTransferEncoding :: OutputStream Builder -> IO (OutputStream Builder)
writeChunkedTransferEncoding os :: 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 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 x :: 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
#else
writeChunkedTransferEncoding os = do
eof <- newIORef True
Streams.makeOutputStream $ f eof
where
f eof Nothing = readIORef eof >>= flip when (do
writeIORef eof True
Streams.write (Just chunkedTransferTerminator) os
Streams.write Nothing os)
f _ x = Streams.write (chunkedTransferEncoding `fmap` x) os
#endif
mAX_CHUNK_SIZE :: Int
mAX_CHUNK_SIZE :: Int
mAX_CHUNK_SIZE = (2::Int)Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(18::Int)
pGetTransferChunk :: Parser (Maybe ByteString)
pGetTransferChunk :: Parser (Maybe ByteString)
pGetTransferChunk = Parser (Maybe ByteString)
parser Parser (Maybe ByteString) -> String -> Parser (Maybe ByteString)
forall a. Parser a -> String -> Parser a
<?> "pGetTransferChunk"
where
parser :: Parser (Maybe ByteString)
parser = do
!Int
hex <- Parser Int
forall a. (Integral a, Bits a) => Parser a
hexadecimal Parser Int -> String -> Parser Int
forall a. Parser a -> String -> Parser a
<?> "hexadecimal"
(Char -> Bool) -> Parser ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\r') Parser () -> String -> Parser ()
forall a. Parser a -> String -> Parser a
<?> "skipToEOL"
Parser ByteString ByteString -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString ByteString
crlf Parser () -> String -> Parser ()
forall a. Parser a -> String -> Parser a
<?> "linefeed"
if Int
hex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
mAX_CHUNK_SIZE
then Maybe ByteString -> Parser (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> Parser (Maybe ByteString))
-> Maybe ByteString -> Parser (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$! HttpParseException -> Maybe ByteString
forall a e. Exception e => e -> a
E.throw (HttpParseException -> Maybe ByteString)
-> HttpParseException -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$! String -> HttpParseException
HttpParseException (String -> HttpParseException) -> String -> HttpParseException
forall a b. (a -> b) -> a -> b
$!
"pGetTransferChunk: chunk of size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
hex String -> ShowS
forall a. [a] -> [a] -> [a]
++ " too long."
else if Int
hex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
then (Parser ByteString ByteString
crlf Parser ByteString ByteString
-> Parser (Maybe ByteString) -> Parser (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ByteString -> Parser (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing) Parser (Maybe ByteString) -> String -> Parser (Maybe ByteString)
forall a. Parser a -> String -> Parser a
<?> "terminal crlf after 0 length"
else do
!ByteString
x <- Int -> Parser ByteString ByteString
take Int
hex Parser ByteString ByteString
-> String -> Parser ByteString ByteString
forall a. Parser a -> String -> Parser a
<?> "reading data chunk"
Parser ByteString ByteString -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString ByteString
crlf Parser () -> String -> Parser ()
forall a. Parser a -> String -> Parser a
<?> "linefeed after data chunk"
Maybe ByteString -> Parser (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> Parser (Maybe ByteString))
-> Maybe ByteString -> Parser (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$! ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
x
toLower :: ByteString -> ByteString
toLower :: ByteString -> ByteString
toLower = (Char -> Char) -> ByteString -> ByteString
S.map Char -> Char
lower
where
lower :: Char -> Char
lower c0 :: Char
c0 = let !c :: Word8
c = Char -> Word8
c2w Char
c0
in if 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
<= 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
+ 32
else Char
c0
elemIndex :: Char -> ByteString -> Int
#if MIN_VERSION_bytestring(0, 10, 6)
elemIndex :: Char -> ByteString -> Int
elemIndex c :: 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
$ \p0 :: 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 (-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 #-}