module Request where
import Control.Monad (forever)
import Control.Proxy (Proxy, liftP, request, respond)
import Control.Proxy.Trans.State (StateP, get, put)
import Control.Exception.Extensible (Exception, throw)
import Data.ByteString (ByteString, elemIndex, empty, split, uncons)
import qualified Data.ByteString as B
import Data.ByteString.Lex.Integral (readDecimal)
import Data.ByteString.Internal (c2w)
import Data.ByteString.Unsafe (unsafeDrop, unsafeIndex, unsafeTake)
import Data.Monoid (mappend)
import Data.Typeable (Typeable)
import Data.Word (Word8)
import Network.Socket (SockAddr(..))
import Types (Method(..), Request(..), HTTPVersion(..))
colon, cr, nl, space :: Word8
colon = c2w ':'
cr = c2w '\r'
nl = c2w '\n'
space = c2w ' '
data ParseError
= Unexpected
| MalformedRequestLine ByteString
| MalformedHeader ByteString
| UnknownHTTPVersion ByteString
deriving (Typeable, Show, Eq)
instance Exception ParseError
parseRequest :: (Proxy p, Monad m) =>
Bool
-> SockAddr
-> StateP ByteString p () ByteString a b m Request
parseRequest secure addr =
do line <- takeLine
let (method, requestURI, httpVersion) = parseRequestLine line
headers <- parseHeaders
let req =
Request { rqMethod = method
, rqURIbs = requestURI
, rqHTTPVersion = httpVersion
, rqHeaders = headers
, rqSecure = secure
, rqClient = addr
}
return $! req
pipeBody :: (Proxy p, Monad m) =>
Request
-> ()
-> StateP ByteString p () ByteString a ByteString m r
pipeBody req () =
case lookup "Content-Length" (rqHeaders req) of
Nothing ->
do error "chunked bodies not supported yet"
(Just value) ->
case readDecimal (B.drop 1 value) of
Nothing -> error $ "Failed to read Content-Length"
(Just (n, _)) ->
do unconsumed <- get
go n unconsumed
where
go remaining unconsumed
| remaining == 0 =
do put unconsumed
done
| remaining >= B.length unconsumed =
do liftP $ respond unconsumed
bs <- liftP $ request ()
go (remaining B.length unconsumed) bs
| remaining == B.length unconsumed =
do liftP $ respond unconsumed
put empty
done
| otherwise =
do let (bs', remainder) = B.splitAt remaining unconsumed
liftP $ respond bs'
put remainder
done
done = forever $ liftP $ respond empty
parseRequestLine :: ByteString -> (Method, ByteString, HTTPVersion)
parseRequestLine bs =
case split space bs of
[method, requestURI, httpVersion] ->
(parseMethod method, requestURI, parseHTTPVersion httpVersion)
_ -> throw (MalformedRequestLine bs)
parseMethod :: ByteString -> Method
parseMethod bs
| bs == "OPTIONS" = OPTIONS
| bs == "GET" = GET
| bs == "HEAD" = HEAD
| bs == "POST" = POST
| bs == "PUT" = PUT
| bs == "DELETE" = DELETE
| bs == "TRACE" = TRACE
| bs == "CONNECT" = CONNECT
| otherwise = EXTENSION bs
parseHTTPVersion :: ByteString -> HTTPVersion
parseHTTPVersion bs
| bs == "HTTP/1.1" = HTTP11
| bs == "HTTP/1.0" = HTTP10
| otherwise = throw (UnknownHTTPVersion bs)
parseHeaders :: (Proxy p, Monad m) => StateP ByteString p () ByteString a b m [(ByteString, ByteString)]
parseHeaders =
do line <- takeLine
if B.null line
then do return []
else do headers <- parseHeaders
return (parseHeader line : headers)
parseHeader :: ByteString -> (ByteString, ByteString)
parseHeader bs =
let (fieldName, remaining) = parseToken bs
in case uncons remaining of
(Just (c, fieldValue))
| c == colon -> (fieldName, fieldValue)
_ -> throw (MalformedHeader bs)
parseToken :: ByteString -> (ByteString, ByteString)
parseToken bs = B.span (/= colon) bs
takeLine :: (Proxy p, Monad m) =>
StateP ByteString p () ByteString a b m ByteString
takeLine =
do bs <- get
case elemIndex nl bs of
Nothing ->
do x <- liftP $ request ()
put (bs `mappend` x)
takeLine
(Just 0) -> throw Unexpected
(Just i) ->
if unsafeIndex bs (i 1) /= cr
then throw Unexpected
else do put $ unsafeDrop (i + 1) bs
return $ unsafeTake (i 1) bs