{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} 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(..)) ------------------------------------------------------------------------------ -- 'Word8' constants for popular characters ------------------------------------------------------------------------------ colon, cr, nl, space :: Word8 colon = c2w ':' cr = c2w '\r' nl = c2w '\n' space = c2w ' ' ------------------------------------------------------------------------------ -- Parse Exception ------------------------------------------------------------------------------ data ParseError = Unexpected | MalformedRequestLine ByteString | MalformedHeader ByteString | UnknownHTTPVersion ByteString deriving (Typeable, Show, Eq) instance Exception ParseError ------------------------------------------------------------------------------ -- Request Parser ------------------------------------------------------------------------------ {- Request = Request-Line ; Section 5.1 *(( general-header ; Section 4.5 | request-header ; Section 5.3 | entity-header ) CRLF) ; Section 7.1 CRLF [ message-body ] ; Section 4.3 -} parseRequest :: (Proxy p, Monad m) => Bool -- ^ is this an HTTPS connection? -> 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 -- | currently if you consume the entire request body this will -- terminate and return the 'ret' value that you supplied. But, that -- seems wrong, because that will tear down the whole pipeline and -- return that value instead of what you really wanted to return. -- -- Perhaps this should return a 'Maybe ByteString' instead so you can -- detect when the body ends? But that interfers with using -- 'parseRequest' in 'httpPipe'. For now we will just return 'empty' -- forever when you get to the end. -- -- Perhaps pipes 2.5 will provide a better solution as it is supposed -- to allow you to catch termination of the upstream pipe. 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 {- The Request-Line begins with a method token, followed by the Request-URI and the protocol version, and ending with CRLF. The elements are separated by SP characters. No CR or LF is allowed except in the final CRLF sequence. Request-Line = Method SP Request-URI SP HTTP-Version CRLF -} parseRequestLine :: ByteString -> (Method, ByteString, HTTPVersion) parseRequestLine bs = case split space bs of [method, requestURI, httpVersion] -> (parseMethod method, requestURI, parseHTTPVersion httpVersion) _ -> throw (MalformedRequestLine bs) {- The Method token indicates the method to be performed on the resource identified by the Request-URI. The method is case-sensitive. Method = "OPTIONS" ; Section 9.2 | "GET" ; Section 9.3 | "HEAD" ; Section 9.4 | "POST" ; Section 9.5 | "PUT" ; Section 9.6 | "DELETE" ; Section 9.7 | "TRACE" ; Section 9.8 | "CONNECT" ; Section 9.9 | extension-method extension-method = token -} 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) -- FIXME: add max header size checks -- parseHeaders :: (Monad m) => ByteString -> Pipe ByteString b m ([(ByteString, ByteString)], ByteString) 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) {- message-header = field-name ":" [ field-value ] field-name = token field-value = *( field-content | LWS ) field-content = -} 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) {- token = 1* separators = "(" | ")" | "<" | ">" | "@" | "," | ";" | ":" | "\" | <"> | "/" | "[" | "]" | "?" | "=" | "{" | "}" | SP | HT CTL = -} -- FIXME: follow the spec parseToken :: ByteString -> (ByteString, ByteString) parseToken bs = B.span (/= colon) bs -- | find a line terminated by a '\r\n' 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 {- parse :: (Monad m) => Pipe ByteString b m a -> String -> m (Maybe a) parse parser str = runPipe $ (yield (C.pack str) >> return Nothing) >+> (fmap Just parser) >+> discard -}