{-# 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) = 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


------------------------------------------------------------------------------
-- | 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 =
        [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

        -- Optimize for the common case: dl is almost always "id"
        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)
splitHeader :: ByteString -> (ByteString, ByteString)
splitHeader !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
pHeaders :: MStandardHeaders -> InputStream ByteString -> IO Headers
pHeaders 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


                             ---------------------
                             -- 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 Int -> Int -> Bool
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 = () -> 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
        -- skip over any chunk extensions (see RFC7230#sec4.1.1)
        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

    {-
        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
        (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


------------------------------------------------------------------------------
-- | 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) = 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 #-}