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)
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
    -- RFC 7230 section 3.1.1 defines the first line of a request as
    --
    --   request-line = method SP request-target SP HTTP-version CRLF
    --
    line <- pLine input
    let (!mStr, !s)     = bSp line
    let (!uri, !vStr)   = bSp s
    let method          = methodFromString mStr
    let (host, uri')    = getHost uri
    let uri''           = if S.null uri' then "/" else uri'
    !version <- pVer vStr

    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)

    -- RFC 7230 section 2.6 defines
    --
    --   HTTP-version = HTTP-name "/" DIGIT "." DIGIT
    --   HTTP-name    = %x48.54.54.50 ; "HTTP", case-sensitive
    --
    pVer s = case bsStripHttpPrefix s of
      Nothing -> return (1, 0)
      Just "1.1" -> return (1, 1)
      Just "1.0" -> return (1, 0)
      Just vstr
        | [mjs,'.',mns] <- S.unpack vstr
        , Just mj <- digitToInt mjs
        , Just mn <- digitToInt mns -> return (mj,mn)
        | otherwise -> throwIO $
            HttpParseException "parse error: invalid HTTP-version in request-line"

    -- NB: 'stripPrefix' operation is available in bytestring-0.10.8 and later
    bsStripHttpPrefix s
      | "HTTP/" `S.isPrefixOf` s = Just $! S.unsafeDrop 5 s
      | otherwise                = Nothing

    digitToInt c
      | n >= 0, n <= 9 = Just n
      | otherwise      = Nothing
      where
        n = fromEnum c - 0x30

    bSp   = splitCh ' '


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