snap-server-0.5.2: src/Snap/Internal/Http/Parser.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
module Snap.Internal.Http.Parser
( IRequest(..)
, HttpParseException
, parseRequest
, readChunkedTransferEncoding
, iterParser
, parseCookie
, parseUrlEncoded
, strictize
) where
------------------------------------------------------------------------------
import Control.Arrow (second)
import Control.Exception
import Control.Monad (liftM)
import Control.Monad.Trans
import Data.Attoparsec hiding (many, Result(..))
import Data.Attoparsec.Enumerator
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Unsafe as S
import Data.ByteString.Internal (w2c)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Nums.Careless.Hex as Cvt
import Data.Char
import Data.List (foldl')
import Data.Int
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import Data.Typeable
import Prelude hiding (head, take, takeWhile)
----------------------------------------------------------------------------
import Snap.Internal.Http.Types
import Snap.Internal.Debug
import Snap.Internal.Iteratee.Debug
import Snap.Internal.Parsing hiding (pHeaders)
import Snap.Iteratee hiding (map, take)
------------------------------------------------------------------------------
-- | an internal version of the headers part of an HTTP request
data IRequest = IRequest
{ iMethod :: Method
, iRequestUri :: ByteString
, iHttpVersion :: (Int,Int)
, iRequestHeaders :: [(ByteString, ByteString)]
}
------------------------------------------------------------------------------
instance Show IRequest where
show (IRequest m u v r) =
concat [ show m
, " "
, show u
, " "
, show v
, " "
, show r ]
------------------------------------------------------------------------------
data HttpParseException = HttpParseException String deriving (Typeable, Show)
instance Exception HttpParseException
------------------------------------------------------------------------------
parseRequest :: (Monad m) => Iteratee ByteString m (Maybe IRequest)
parseRequest = do
eof <- isEOF
if eof
then return Nothing
else do
line <- pLine
if S.null line
then parseRequest
else do
let (!mStr,!s) = bSp line
let (!uri,!vStr) = bSp s
!method <- methodFromString mStr
let ver@(!_,!_) = pVer vStr
hdrs <- pHeaders
return $ Just $ IRequest method uri ver hdrs
where
pVer s = if S.isPrefixOf "HTTP/" s
then let (a,b) = bDot $ S.drop 5 s
in (read $ S.unpack a, read $ S.unpack b)
else (1,0)
isSp = (== ' ')
bSp = splitWith isSp
isDot = (== '.')
bDot = splitWith isDot
------------------------------------------------------------------------------
pLine :: (Monad m) => Iteratee ByteString m ByteString
pLine = continue $ k S.empty
where
k _ EOF = throwError $
HttpParseException "parse error: expected line ending in crlf"
k !pre (Chunks xs) =
if S.null b
then continue $ k a
else yield a (Chunks [S.drop 2 b])
where
(!a,!b) = S.breakSubstring "\r\n" s
!s = S.append pre s'
!s' = S.concat xs
------------------------------------------------------------------------------
splitWith :: (Char -> Bool) -> ByteString -> (ByteString,ByteString)
splitWith !f !s = let (!a,!b) = S.break f s
!b' = S.dropWhile f b
in (a, b')
------------------------------------------------------------------------------
pHeaders :: Monad m => Iteratee ByteString m [(ByteString,ByteString)]
pHeaders = do
f <- go id
return $! f []
where
go !dlistSoFar = {-# SCC "pHeaders/go" #-} do
line <- pLine
if S.null line
then return dlistSoFar
else do
let (!k,!v) = pOne line
vf <- pCont id
let vs = vf []
let !v' = S.concat (v:vs)
go (dlistSoFar . ((k,v'):))
where
pOne s = let (k,v) = splitWith (== ':') s
in (trim k, trim v)
isCont c = c == ' ' || c == '\t'
pCont !dlist = do
mbS <- peek
maybe (return dlist)
(\s -> if S.null s
then head >> pCont dlist
else if isCont $ w2c $ S.unsafeHead s
then procCont dlist
else return dlist)
mbS
procCont !dlist = do
line <- pLine
let !t = trim line
pCont (dlist . (" ":) . (t:))
------------------------------------------------------------------------------
methodFromString :: (Monad m) => ByteString -> Iteratee ByteString m Method
methodFromString "GET" = return GET
methodFromString "POST" = return POST
methodFromString "HEAD" = return HEAD
methodFromString "PUT" = return PUT
methodFromString "DELETE" = return DELETE
methodFromString "TRACE" = return TRACE
methodFromString "OPTIONS" = return OPTIONS
methodFromString "CONNECT" = return CONNECT
methodFromString s =
throwError $ HttpParseException $ "Bad method '" ++ S.unpack s ++ "'"
------------------------------------------------------------------------------
readChunkedTransferEncoding :: (MonadIO m) =>
Enumeratee ByteString ByteString m a
readChunkedTransferEncoding =
chunkParserToEnumeratee $
iterateeDebugWrapper "pGetTransferChunk" $
iterParser pGetTransferChunk
------------------------------------------------------------------------------
chunkParserToEnumeratee :: (MonadIO m) =>
Iteratee ByteString m (Maybe ByteString)
-> Enumeratee ByteString ByteString m a
chunkParserToEnumeratee getChunk client = do
mbB <- getChunk
maybe finishIt sendBS mbB
where
sendBS s = do
step <- lift $ runIteratee $ enumBS s client
chunkParserToEnumeratee getChunk step
finishIt = lift $ runIteratee $ enumEOF client
------------------------------------------------------------------------------
-- parse functions
------------------------------------------------------------------------------
------------------------------------------------------------------------------
pGetTransferChunk :: Parser (Maybe ByteString)
pGetTransferChunk = do
!hex <- liftM fromHex $ (takeWhile (isHexDigit . w2c))
takeTill ((== '\r') . w2c)
crlf
if hex <= 0
then return Nothing
else do
x <- take hex
crlf
return $ Just x
where
fromHex :: ByteString -> Int
fromHex s = Cvt.hex (L.fromChunks [s])
------------------------------------------------------------------------------
-- COOKIE PARSING
------------------------------------------------------------------------------
-- these definitions try to mirror RFC-2068 (the HTTP/1.1 spec) and RFC-2109
-- (cookie spec): please point out any errors!
------------------------------------------------------------------------------
pCookies :: Parser [Cookie]
pCookies = do
-- grab kvps and turn to strict bytestrings
kvps <- pAvPairs
return $ map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps
where
toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing
------------------------------------------------------------------------------
parseCookie :: ByteString -> Maybe [Cookie]
parseCookie = parseToCompletion pCookies
------------------------------------------------------------------------------
-- application/x-www-form-urlencoded
------------------------------------------------------------------------------
------------------------------------------------------------------------------
parseUrlEncoded :: ByteString -> Map ByteString [ByteString]
parseUrlEncoded s = foldl' (\m (k,v) -> Map.insertWith' (++) k [v] m)
Map.empty
decoded
where
breakApart = (second (S.drop 1)) . S.break (== '=')
parts :: [(ByteString,ByteString)]
parts = map breakApart $ S.splitWith (\c -> c == '&' || c == ';') s
urldecode = parseToCompletion pUrlEscaped
decodeOne (a,b) = do
a' <- urldecode a
b' <- urldecode b
return (a',b')
decoded = catMaybes $ map decodeOne parts