diff --git a/mongrel2-handler.cabal b/mongrel2-handler.cabal --- a/mongrel2-handler.cabal +++ b/mongrel2-handler.cabal @@ -1,5 +1,5 @@ Name: mongrel2-handler -Version: 0.1.1 +Version: 0.1.2 Synopsis: Mongrel2 Handler Library Description: Mongrel2 Handler Library. License: MIT @@ -12,16 +12,17 @@ Stability: Unstable Library - Build-Depends: base >= 4.0 && <5 - , aeson >= 0.3 && <0.4 - , attoparsec >= 0.8.5.0 && < 0.9 - , blaze-builder >= 0.3 && < 0.4 - , blaze-textual >= 0.1 && < 0.2 - , bytestring >= 0.9.0.1 - , containers >= 0.3 && < 0.5 - , http-types >= 0.6 && < 0.7 - , text >= 0.11 && < 0.12 - , zeromq-haskell >= 0.6 && < 0.7 + Build-Depends: base >= 4.0 && <5 + , aeson >= 0.3 && <0.4 + , attoparsec >= 0.8.5.0 && < 0.9 + , blaze-builder >= 0.3 && < 0.4 + , blaze-textual >= 0.1 && < 0.2 + , bytestring >= 0.9.0.1 + , case-insensitive >= 0.2 && < 0.3 + , containers >= 0.3 && < 0.5 + , http-types >= 0.6 && < 0.7 + , text >= 0.11 && < 0.12 + , zeromq-haskell >= 0.6 && < 0.7 Extensions: OverloadedStrings Ghc-options: -Wall -fno-warn-unused-matches Hs-source-dirs: src diff --git a/src/Mongrel2.hs b/src/Mongrel2.hs --- a/src/Mongrel2.hs +++ b/src/Mongrel2.hs @@ -6,14 +6,15 @@ , receiveRequest , sendReply -- Re-exported - , Message + , Request(..) , UUID , ClientID ) where import Blaze.ByteString.Builder (Builder) import Data.Attoparsec -import Mongrel2.Parser (messageParser, Message, UUID, ClientID) +import Mongrel2.Types (Request(..)) +import Mongrel2.Parser (messageParser, UUID, ClientID) import Mongrel2.Response (mkResponse) import qualified System.ZMQ as ZMQ @@ -50,7 +51,7 @@ -- | Receive a parsed request from the Mongrel2 server. Blocks until -- a message is received. -receiveRequest :: ConnectedHandler -> IO Message +receiveRequest :: ConnectedHandler -> IO Request receiveRequest handler = do msg <- ZMQ.receive (chPullSocket handler) [] -- Parse into a structured message. diff --git a/src/Mongrel2/Parser.hs b/src/Mongrel2/Parser.hs --- a/src/Mongrel2/Parser.hs +++ b/src/Mongrel2/Parser.hs @@ -1,9 +1,5 @@ module Mongrel2.Parser ( ClientID - , Message - , Path - , RequestHeaders - , RequestBody , UUID , messageParser ) where @@ -12,22 +8,18 @@ import Data.Attoparsec import Data.Attoparsec.Char8 (decimal) import Data.ByteString (ByteString) -import Data.Text (Text) +import Data.CaseInsensitive (CI) +import Data.Map (Map) +import Data.Maybe (catMaybes) +import Data.Text (Text, uncons) import Data.Text.Encoding (encodeUtf8) import Data.Word (Word8) -import Mongrel2.Types (UUID, ClientID) -import Network.HTTP.Types (Query, decodePath) +import Mongrel2.Types (Request(..), UUID, ClientID) +import Network.HTTP.Types (HttpVersion, Method, Query, RequestHeaders, decodePath, http09, http10, http11, parseMethod) import Prelude hiding (take) +import qualified Data.CaseInsensitive as CI import qualified Data.Map as M -type Path = ByteString - -type RequestHeaders = Value - -type RequestBody = ByteString - -type Message = (UUID, ClientID, Path, RequestHeaders, RequestBody, ([Text], Query)) - -- Predicates for parsing. isSpace :: Word8 -> Bool isSpace 0x20 = True @@ -59,22 +51,59 @@ str <- contentParser len return str -messageParser :: Parser Message +messageParser :: Parser Request messageParser = do uuid <- uuidParser skipSpace clientId <- decimal skipSpace - path <- takeTill isSpace + rawPath <- takeTill isSpace skipSpace - reqHdr <- netstringParser $ \_ -> json + rawReqHdr <- netstringParser $ \_ -> json skip isComma - reqBody <- netstringParser take - return (uuid,clientId,path,reqHdr,reqBody,extractQuery reqHdr) + body <- netstringParser take + -- Touchups to conform better with Http-types. + let reqHdr = unHeaders rawReqHdr + let method = parseMethod $ extractMethod reqHdr + let version = extractVersion reqHdr + let (path,query) = extractQuery reqHdr + return $ Request path query rawPath method version (extractHeaders reqHdr) body uuid clientId -extractQuery :: Value -> ([Text], Query) -extractQuery (Object hdrs) = +unHeaders :: Value -> Map Text Value +unHeaders (Object m) = m +unHeaders _ = error "Invalid headers received from Mongrel2" + +extractQuery :: Map Text Value -> ([Text], Query) +extractQuery hdrs = case M.lookup "URI" hdrs of Just (String uriText) -> decodePath $ encodeUtf8 uriText - _ -> fail "Missing/invalid 'URI' in headers received from Mongrel2" -extractQuery _ = fail "Invalid headers received from Mongrel2" + _ -> error "Missing/invalid 'URI' in headers received from Mongrel2" + +extractMethod :: Map Text Value -> Method +extractMethod hdrs = + case M.lookup "METHOD" hdrs of + Just (String methodText) -> encodeUtf8 methodText + _ -> error "Missing/invalid 'METHOD' in headers received from Mongrel2" + +extractVersion :: Map Text Value -> HttpVersion +extractVersion hdrs = + -- TODO: This really should be done in a more general way. + case M.lookup "VERSION" hdrs of + Just s | (s == "HTTP/0.9") -> http09 + Just s | (s == "HTTP/1.0") -> http10 + Just s | (s == "HTTP/1.1") -> http11 + Just _ -> error "Unrecognized HTTP version" + Nothing -> error "Missing HTTP version in headers received from Mongrel2" + +extractHeaders :: Map Text Value -> RequestHeaders +extractHeaders hdrs = catMaybes $ map extractHdr $ M.toList hdrs + +extractHdr :: (Text, Value) -> Maybe (CI ByteString, ByteString) +extractHdr (t, String v) = handleHdr t v +extractHdr _ = Nothing + +handleHdr :: Text -> Text -> Maybe (CI ByteString, ByteString) +handleHdr k v = + case uncons k of + Just (c, _) | (c >= 'A' && c <= 'Z') -> Nothing + _ -> Just (CI.mk $ encodeUtf8 k, encodeUtf8 v) diff --git a/src/Mongrel2/Types.hs b/src/Mongrel2/Types.hs --- a/src/Mongrel2/Types.hs +++ b/src/Mongrel2/Types.hs @@ -1,10 +1,13 @@ module Mongrel2.Types ( ClientID + , Request(..) , UUID ) where import Data.ByteString (ByteString) import Data.Int (Int64) +import Data.Text (Text) +import Network.HTTP.Types (Ascii, HttpVersion, RequestHeaders, StdMethod, Query) -- | Client identifier from Mongrel2. This identifies the currently -- connected client uniquely. @@ -13,3 +16,24 @@ -- | UUID for communicating with Mongrel2. type UUID = ByteString +-- | Request information. +data Request = Request { + -- ^ Request path + reqPath :: [Text], + -- | Query part of the request + reqQuery :: Query, + -- | Raw request path including query part. + reqRawPath :: ByteString, + -- | Request method (GET, POST, etc.) + reqMethod :: Either Ascii StdMethod, + -- | HTTP version + reqVersion :: HttpVersion, + -- | Request headers + reqHeaders :: RequestHeaders, + -- | Request body. + reqBody :: ByteString, + -- | UUID of the connected Mongrel2 server. + reqServerUUID :: UUID, + -- | ID of the connected client browser. + reqClientID :: ClientID + } deriving (Show)