{-# 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
findStdHeaderIndex :: ByteString -> Int
findStdHeaderIndex 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) = forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
contentLengthTag
getStdHost :: StandardHeaders -> Maybe ByteString
getStdHost             (StandardHeaders Vector (Maybe ByteString)
v) = forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
hostTag
getStdTransferEncoding :: StandardHeaders -> Maybe ByteString
getStdTransferEncoding (StandardHeaders Vector (Maybe ByteString)
v) = forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
transferEncodingTag
getStdCookie :: StandardHeaders -> Maybe ByteString
getStdCookie           (StandardHeaders Vector (Maybe ByteString)
v) = forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
cookieTag
getStdContentType :: StandardHeaders -> Maybe ByteString
getStdContentType      (StandardHeaders Vector (Maybe ByteString)
v) = forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
contentTypeTag
getStdConnection :: StandardHeaders -> Maybe ByteString
getStdConnection       (StandardHeaders Vector (Maybe ByteString)
v) = forall a. Vector a -> Int -> a
V.unsafeIndex Vector (Maybe ByteString)
v Int
connectionTag


------------------------------------------------------------------------------
newMStandardHeaders :: IO MStandardHeaders
newMStandardHeaders :: IO MStandardHeaders
newMStandardHeaders = forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
MV.replicate Int
nStandardHeaders forall a. Maybe a
Nothing


------------------------------------------------------------------------------
-- | an internal version of the headers part of an HTTP request
data IRequest = IRequest
    { IRequest -> Method
iMethod         :: !Method
    , IRequest -> ByteString
iRequestUri     :: !ByteString
    , IRequest -> (Int, Int)
iHttpVersion    :: (Int, Int)
    , IRequest -> Headers
iRequestHeaders :: Headers
    , IRequest -> StandardHeaders
iStdHeaders     :: StandardHeaders
    }

------------------------------------------------------------------------------
instance Eq IRequest where
    IRequest
a == :: IRequest -> IRequest -> Bool
== IRequest
b =
        forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ IRequest -> Method
iMethod IRequest
a      forall a. Eq a => a -> a -> Bool
== IRequest -> Method
iMethod IRequest
b
            , IRequest -> ByteString
iRequestUri IRequest
a  forall a. Eq a => a -> a -> Bool
== IRequest -> ByteString
iRequestUri IRequest
b
            , IRequest -> (Int, Int)
iHttpVersion IRequest
a forall a. Eq a => a -> a -> Bool
== IRequest -> (Int, Int)
iHttpVersion IRequest
b
            , forall a. Ord a => [a] -> [a]
sort (Headers -> [(CI ByteString, ByteString)]
H.toList (IRequest -> Headers
iRequestHeaders IRequest
a))
                  forall a. Eq a => a -> a -> Bool
== 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
_) =
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ forall a. Show a => a -> String
show Method
m
               , String
" "
               , forall a. Show a => a -> String
show ByteString
u
               , String
" "
               , forall a. Show a => a -> String
show Int
major
               , String
"."
               , forall a. Show a => a -> String
show Int
minor
               , String
" "
               , forall a. Show a => a -> String
show Headers
hdrs
               ]


------------------------------------------------------------------------------
data HttpParseException = HttpParseException String deriving (Typeable, Int -> HttpParseException -> ShowS
[HttpParseException] -> ShowS
HttpParseException -> String
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        = 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
    forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.unsafeWrite MStandardHeaders
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MStandardHeaders
stdHdrs
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall a. a -> Maybe a
Just 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 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! ByteString
host, ByteString
uri)
              | Bool
otherwise = (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 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         = forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat ByteString
a
        !d :: b
d         = 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 =
        forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$
        String -> HttpParseException
HttpParseException String
"parse error: expected line ending in crlf"

    throwBadCRLF :: IO a
throwBadCRLF =
        forall e a. Exception e => e -> IO a
throwIO 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 <- forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input
        !ByteString
s  <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. IO a
throwNoCRLF 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 forall a. Ord a => a -> a -> Bool
< Int
0
          then [ByteString] -> ByteString -> IO ByteString
noCRLF [ByteString]
l ByteString
s
          else case () of
                 !()
_ | Int
iforall a. Num a => a -> a -> a
+Int
1 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
iforall a. Num a => a -> a -> a
+Int
1) forall a. Eq a => a -> a -> Bool
== Word8
10 -> [ByteString] -> ByteString -> Int -> IO ByteString
foundCRLF [ByteString]
l ByteString
s Int
i
                    | Bool
otherwise                   -> 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 forall a. Num a => a -> a -> a
+ Int
2
        let !a :: ByteString
a = Int -> ByteString -> ByteString
S.unsafeTake Int
i1 ByteString
s
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i2 forall a. Ord a => a -> a -> Bool
< ByteString -> Int
S.length ByteString
s) forall a b. (a -> b) -> a -> b
$ do
            let !b :: ByteString
b = Int -> ByteString -> ByteString
S.unsafeDrop Int
i2 ByteString
s
            forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
b InputStream ByteString
input

        -- Optimize for the common case: dl is almost always "id"
        let !out :: ByteString
out = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
l then ByteString
a else [ByteString] -> ByteString
S.concat (forall a. [a] -> [a]
reverse (ByteString
aforall a. a -> [a] -> [a]
:[ByteString]
l))
        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
sforall a. a -> [a] -> [a]
:[ByteString]
l)

    lastIsCR :: [ByteString] -> ByteString -> Int -> IO ByteString
lastIsCR [ByteString]
l ByteString
s !Int
idx = do
        !ByteString
t <- forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. IO a
throwNoCRLF 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 forall a. Eq a => a -> a -> Bool
/= Word8
10
              then 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
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
S.null ByteString
b) forall a b. (a -> b) -> a -> b
$ forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
b InputStream ByteString
input
                  let !out :: ByteString
out = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
l then ByteString
a else [ByteString] -> ByteString
S.concat (forall a. [a] -> [a]
reverse (ByteString
aforall a. a -> [a] -> [a]
:[ByteString]
l))
                  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 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 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 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)
splitHeader :: ByteString -> (ByteString, ByteString)
splitHeader !ByteString
s = if Int
idx 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 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 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 forall a b. (a -> b) -> a -> b
$ Word8 -> Char
w2c Word8
c
                                 then Int -> ByteString
skipSp forall a b. (a -> b) -> a -> b
$ Int
i 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 forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\t'
{-# INLINE isLWS #-}


------------------------------------------------------------------------------
pHeaders :: MStandardHeaders -> InputStream ByteString -> IO Headers
pHeaders :: MStandardHeaders -> InputStream ByteString -> IO Headers
pHeaders MStandardHeaders
stdHdrs InputStream ByteString
input = do
    Headers
hdrs    <- [(ByteString, ByteString)] -> Headers
H.unsafeFromCaseFoldedList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ByteString, ByteString)] -> IO [(ByteString, ByteString)]
go []
    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 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 <- forall {c}. ([ByteString] -> c) -> IO ([ByteString] -> c)
pCont forall a. a -> a
id
            let vs :: [ByteString]
vs = [ByteString] -> [ByteString]
vf []
            let !v' :: ByteString
v' = [ByteString] -> ByteString
S.concat (ByteString
vforall a. a -> [a] -> [a]
:[ByteString]
vs)
            let idx :: Int
idx = ByteString -> Int
findStdHeaderIndex ByteString
k
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
idx forall a. Ord a => a -> a -> Bool
>= Int
0) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.unsafeWrite MStandardHeaders
stdHdrs Int
idx forall a b. (a -> b) -> a -> b
$! forall a. a -> Maybe a
Just ByteString
v'

            let l' :: [(ByteString, ByteString)]
l' = ((ByteString
k, ByteString
v')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  <- forall a. InputStream a -> IO (Maybe a)
Streams.peek InputStream ByteString
input
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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 forall a b. (a -> b) -> a -> b
$ Char -> Bool
isLWS forall a b. (a -> b) -> a -> b
$ Word8 -> Char
w2c forall a b. (a -> b) -> a -> b
$ ByteString -> Word8
S.unsafeHead ByteString
s
                              then forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString] -> c
dlist
                              else ([ByteString] -> c) -> IO ([ByteString] -> c)
procCont [ByteString] -> c
dlist
                       else forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
" "forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
tforall 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 =
    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 = forall a. (Maybe a -> IO ()) -> IO (OutputStream a)
Streams.makeOutputStream Maybe Builder -> IO ()
f
  where
    f :: Maybe Builder -> IO ()
f Maybe Builder
Nothing = do
        forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
chunkedTransferTerminator) OutputStream Builder
os
        forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream Builder
os
    f Maybe Builder
x = forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Builder
chunkedTransferEncoding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe Builder
x) OutputStream Builder
os


                             ---------------------
                             -- parse functions --
                             ---------------------

------------------------------------------------------------------------------
{-
    For a response body in chunked transfer encoding, iterate over
    the individual chunks, reading the size parameter, then
    looping over that chunk in bites of at most bUFSIZ,
    yielding them to the receiveResponse InputStream accordingly.
-}
consumeChunks :: InputStream ByteString -> Generator ByteString ()
consumeChunks :: InputStream ByteString -> Generator ByteString ()
consumeChunks InputStream ByteString
i1 = do
    !Int
n <- Generator ByteString Int
parseSize
    if Int
n forall a. Ord a => a -> a -> Bool
> Int
0
        then do
            -- read one or more bytes, then loop to next chunk
            Int -> Generator ByteString ()
go Int
n
            Generator ByteString ()
skipCRLF
            InputStream ByteString -> Generator ByteString ()
consumeChunks InputStream ByteString
i1
        else do
            -- NB: snap-server doesn't yet support chunked trailer parts
            -- (see RFC7230#sec4.1.2)

            -- consume final CRLF
            Generator ByteString ()
skipCRLF

  where
    go :: Int -> Generator ByteString ()
go Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go !Int
n = do
        (!ByteString
x',!Int
r) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> InputStream ByteString -> IO (ByteString, Int)
readN Int
n InputStream ByteString
i1
        forall r. r -> Generator r ()
Streams.yield ByteString
x'
        Int -> Generator ByteString ()
go Int
r

    parseSize :: Generator ByteString Int
parseSize = do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream Parser Int
transferChunkSize InputStream ByteString
i1

    skipCRLF :: Generator ByteString ()
skipCRLF = do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void (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 <- forall a. (Integral a, Bits a) => Parser a
hexadecimal
        -- skip over any chunk extensions (see RFC7230#sec4.1.1)
        forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Char -> Bool) -> Parser ByteString
takeTill (forall a. Eq a => a -> a -> Bool
== Char
'\r'))
        forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString
crlf
        forall (m :: * -> *) a. Monad m => a -> m a
return Int
n

    {-
        The chunk size coming down from the client is somewhat arbitrary;
        it's really just an indication of how many bytes need to be read
        before the next size marker or end marker - neither of which has
        anything to do with streaming on our side. Instead, we'll feed
        bytes into our InputStream at an appropriate intermediate size.
    -}
    bUFSIZ :: Int
    bUFSIZ :: Int
bUFSIZ = Int
32752

    {-
        Read the specified number of bytes up to a maximum of bUFSIZ,
        returning a resultant ByteString and the number of bytes remaining.
    -}
    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
        forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
x', Int
r)
      where
        !d :: Int
d = Int
n forall a. Num a => a -> a -> a
- Int
bUFSIZ
        !p :: Int
p = if Int
d forall a. Ord a => a -> a -> Bool
> Int
0 then Int
bUFSIZ else Int
n
        !r :: Int
r = if Int
d 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 forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
90
                    then Word8 -> Char
w2c forall a b. (a -> b) -> a -> b
$! Word8
c forall a. Num a => a -> a -> a
+ Word8
32
                    else Char
c0


------------------------------------------------------------------------------
-- | A version of elemIndex that doesn't allocate a Maybe. (It returns -1 on
-- not found.)
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) = forall a. IO a -> a
accursedUnutterablePerformIO forall a b. (a -> b) -> a -> b
$
#else
elemIndex c (PS !fp !start !len) = inlinePerformIO $
#endif
                                   forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p0 -> do
    let !p :: Ptr b
p = 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 forall {b}. Ptr b
p Word8
w8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! if Ptr Word8
q forall a. Eq a => a -> a -> Bool
== forall {b}. Ptr b
nullPtr then (-Int
1) else Ptr Word8
q forall a b. Ptr a -> Ptr b -> Int
`minusPtr` forall {b}. Ptr b
p
  where
    !w8 :: Word8
w8 = Char -> Word8
c2w Char
c
{-# INLINE elemIndex #-}