snap-server-1.1.2.0: src/Snap/Internal/Http/Server/Parser.hs
{-# 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 = 0
hostTag = 1
transferEncodingTag = 2
cookieTag = 3
contentTypeTag = 4
connectionTag = 5
nStandardHeaders = 6
------------------------------------------------------------------------------
findStdHeaderIndex :: ByteString -> Int
findStdHeaderIndex "content-length" = contentLengthTag
findStdHeaderIndex "host" = hostTag
findStdHeaderIndex "transfer-encoding" = transferEncodingTag
findStdHeaderIndex "cookie" = cookieTag
findStdHeaderIndex "content-type" = contentTypeTag
findStdHeaderIndex "connection" = connectionTag
findStdHeaderIndex _ = -1
------------------------------------------------------------------------------
getStdContentLength, getStdHost, getStdTransferEncoding, getStdCookie,
getStdConnection, getStdContentType :: StandardHeaders -> Maybe ByteString
getStdContentLength (StandardHeaders v) = V.unsafeIndex v contentLengthTag
getStdHost (StandardHeaders v) = V.unsafeIndex v hostTag
getStdTransferEncoding (StandardHeaders v) = V.unsafeIndex v transferEncodingTag
getStdCookie (StandardHeaders v) = V.unsafeIndex v cookieTag
getStdContentType (StandardHeaders v) = V.unsafeIndex v contentTypeTag
getStdConnection (StandardHeaders v) = V.unsafeIndex v connectionTag
------------------------------------------------------------------------------
newMStandardHeaders :: IO MStandardHeaders
newMStandardHeaders = MV.replicate nStandardHeaders Nothing
------------------------------------------------------------------------------
-- | an internal version of the headers part of an HTTP request
data IRequest = IRequest
{ iMethod :: !Method
, iRequestUri :: !ByteString
, iHttpVersion :: (Int, Int)
, iRequestHeaders :: Headers
, iStdHeaders :: StandardHeaders
}
------------------------------------------------------------------------------
instance Eq IRequest where
a == b =
and [ iMethod a == iMethod b
, iRequestUri a == iRequestUri b
, iHttpVersion a == iHttpVersion b
, sort (H.toList (iRequestHeaders a))
== sort (H.toList (iRequestHeaders b))
]
------------------------------------------------------------------------------
instance Show IRequest where
show (IRequest m u (major, minor) hdrs _) =
concat [ show m
, " "
, show u
, " "
, show major
, "."
, show minor
, " "
, show hdrs
]
------------------------------------------------------------------------------
data HttpParseException = HttpParseException String deriving (Typeable, Show)
instance Exception HttpParseException
------------------------------------------------------------------------------
{-# INLINE parseRequest #-}
parseRequest :: InputStream ByteString -> IO IRequest
parseRequest input = do
line <- pLine input
let (!mStr, !s) = bSp line
let (!uri, !vStr) = bSp s
let method = methodFromString mStr
let !version = pVer vStr
let (host, uri') = getHost uri
let uri'' = if S.null uri' then "/" else uri'
stdHdrs <- newMStandardHeaders
MV.unsafeWrite stdHdrs hostTag host
hdrs <- pHeaders stdHdrs input
outStd <- StandardHeaders <$> V.unsafeFreeze stdHdrs
return $! IRequest method uri'' version hdrs outStd
where
getHost s | "http://" `S.isPrefixOf` s
= let s' = S.unsafeDrop 7 s
(!host, !uri) = breakCh '/' s'
in (Just $! host, uri)
| "https://" `S.isPrefixOf` s
= let s' = S.unsafeDrop 8 s
(!host, !uri) = breakCh '/' s'
in (Just $! host, uri)
| otherwise = (Nothing, s)
pVer s = if "HTTP/" `S.isPrefixOf` s
then pVers (S.unsafeDrop 5 s)
else (1, 0)
bSp = splitCh ' '
pVers s = (c, d)
where
(!a, !b) = splitCh '.' s
!c = unsafeFromNat a
!d = unsafeFromNat b
------------------------------------------------------------------------------
pLine :: InputStream ByteString -> IO ByteString
pLine input = go []
where
throwNoCRLF =
throwIO $
HttpParseException "parse error: expected line ending in crlf"
throwBadCRLF =
throwIO $
HttpParseException "parse error: got cr without subsequent lf"
go !l = do
!mb <- Streams.read input
!s <- maybe throwNoCRLF return mb
let !i = elemIndex '\r' s
if i < 0
then noCRLF l s
else case () of
!_ | i+1 >= S.length s -> lastIsCR l s i
| S.unsafeIndex s (i+1) == 10 -> foundCRLF l s i
| otherwise -> throwBadCRLF
foundCRLF l s !i1 = do
let !i2 = i1 + 2
let !a = S.unsafeTake i1 s
when (i2 < S.length s) $ do
let !b = S.unsafeDrop i2 s
Streams.unRead b input
-- Optimize for the common case: dl is almost always "id"
let !out = if null l then a else S.concat (reverse (a:l))
return out
noCRLF l s = go (s:l)
lastIsCR l s !idx = do
!t <- Streams.read input >>= maybe throwNoCRLF return
if S.null t
then lastIsCR l s idx
else do
let !c = S.unsafeHead t
if c /= 10
then throwBadCRLF
else do
let !a = S.unsafeTake idx s
let !b = S.unsafeDrop 1 t
when (not $ S.null b) $ Streams.unRead b input
let !out = if null l then a else S.concat (reverse (a:l))
return out
------------------------------------------------------------------------------
splitCh :: Char -> ByteString -> (ByteString, ByteString)
splitCh !c !s = if idx < 0
then (s, S.empty)
else let !a = S.unsafeTake idx s
!b = S.unsafeDrop (idx + 1) s
in (a, b)
where
!idx = elemIndex c s
{-# INLINE splitCh #-}
------------------------------------------------------------------------------
breakCh :: Char -> ByteString -> (ByteString, ByteString)
breakCh !c !s = if idx < 0
then (s, S.empty)
else let !a = S.unsafeTake idx s
!b = S.unsafeDrop idx s
in (a, b)
where
!idx = elemIndex c s
{-# INLINE breakCh #-}
------------------------------------------------------------------------------
splitHeader :: ByteString -> (ByteString, ByteString)
splitHeader !s = if idx < 0
then (s, S.empty)
else let !a = S.unsafeTake idx s
in (a, skipSp (idx + 1))
where
!idx = elemIndex ':' s
l = S.length s
skipSp !i | i >= l = S.empty
| otherwise = let c = S.unsafeIndex s i
in if isLWS $ w2c c
then skipSp $ i + 1
else S.unsafeDrop i s
{-# INLINE splitHeader #-}
------------------------------------------------------------------------------
isLWS :: Char -> Bool
isLWS c = c == ' ' || c == '\t'
{-# INLINE isLWS #-}
------------------------------------------------------------------------------
pHeaders :: MStandardHeaders -> InputStream ByteString -> IO Headers
pHeaders stdHdrs input = do
hdrs <- H.unsafeFromCaseFoldedList <$> go []
return hdrs
where
go !list = do
line <- pLine input
if S.null line
then return list
else do
let (!k0,!v) = splitHeader line
let !k = toLower k0
vf <- pCont id
let vs = vf []
let !v' = S.concat (v:vs)
let idx = findStdHeaderIndex k
when (idx >= 0) $ MV.unsafeWrite stdHdrs idx $! Just v'
let l' = ((k, v'):list)
go l'
trimBegin = S.dropWhile isLWS
pCont !dlist = do
mbS <- Streams.peek input
maybe (return dlist)
(\s -> if not (S.null s)
then if not $ isLWS $ w2c $ S.unsafeHead s
then return dlist
else procCont dlist
else Streams.read input >> pCont dlist)
mbS
procCont !dlist = do
line <- pLine input
let !t = trimBegin line
pCont (dlist . (" ":) . (t:))
------------------------------------------------------------------------------
methodFromString :: ByteString -> Method
methodFromString "GET" = GET
methodFromString "POST" = POST
methodFromString "HEAD" = HEAD
methodFromString "PUT" = PUT
methodFromString "DELETE" = DELETE
methodFromString "TRACE" = TRACE
methodFromString "OPTIONS" = OPTIONS
methodFromString "CONNECT" = CONNECT
methodFromString "PATCH" = PATCH
methodFromString s = Method s
------------------------------------------------------------------------------
readChunkedTransferEncoding :: InputStream ByteString
-> IO (InputStream ByteString)
readChunkedTransferEncoding input =
Streams.fromGenerator (consumeChunks input)
------------------------------------------------------------------------------
writeChunkedTransferEncoding :: OutputStream Builder
-> IO (OutputStream Builder)
writeChunkedTransferEncoding os = Streams.makeOutputStream f
where
f Nothing = do
Streams.write (Just chunkedTransferTerminator) os
Streams.write Nothing os
f x = Streams.write (chunkedTransferEncoding `fmap` x) 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 i1 = do
!n <- parseSize
if n > 0
then do
-- read one or more bytes, then loop to next chunk
go n
skipCRLF
consumeChunks i1
else do
-- NB: snap-server doesn't yet support chunked trailer parts
-- (see RFC7230#sec4.1.2)
-- consume final CRLF
skipCRLF
where
go 0 = return ()
go !n = do
(!x',!r) <- liftIO $ readN n i1
Streams.yield x'
go r
parseSize = do
liftIO $ parseFromStream transferChunkSize i1
skipCRLF = do
liftIO $ void (parseFromStream crlf i1)
transferChunkSize :: Parser (Int)
transferChunkSize = do
!n <- hexadecimal
-- skip over any chunk extensions (see RFC7230#sec4.1.1)
void (takeTill (== '\r'))
void crlf
return 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 = 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 n input = do
!x' <- Streams.readExactly p input
return (x', r)
where
!d = n - bUFSIZ
!p = if d > 0 then bUFSIZ else n
!r = if d > 0 then d else 0
------------------------------------------------------------------------------
toLower :: ByteString -> ByteString
toLower = S.map lower
where
lower c0 = let !c = c2w c0
in if 65 <= c && c <= 90
then w2c $! c + 32
else 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 c (PS !fp !start !len) = accursedUnutterablePerformIO $
#else
elemIndex c (PS !fp !start !len) = inlinePerformIO $
#endif
withForeignPtr fp $ \p0 -> do
let !p = plusPtr p0 start
q <- memchr p w8 (fromIntegral len)
return $! if q == nullPtr then (-1) else q `minusPtr` p
where
!w8 = c2w c
{-# INLINE elemIndex #-}