{-# 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
findStdHeaderIndex :: ByteString -> Int
findStdHeaderIndex "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


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

        -- 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 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)
splitHeader :: ByteString -> (ByteString, ByteString)
splitHeader !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
pHeaders :: MStandardHeaders -> InputStream ByteString -> IO Headers
pHeaders 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
    -- make sure we only send the terminator once.
    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


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

------------------------------------------------------------------------------
-- We treat chunks larger than this from clients as a denial-of-service attack.
-- 256kB should be enough buffer.
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
                -- now safe to take this many bytes.
                !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


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