mongrel2-handler 0.1.1 → 0.1.2
raw patch · 4 files changed
+93/−38 lines, 4 filesdep +case-insensitive
Dependencies added: case-insensitive
Files
- mongrel2-handler.cabal +12/−11
- src/Mongrel2.hs +4/−3
- src/Mongrel2/Parser.hs +53/−24
- src/Mongrel2/Types.hs +24/−0
mongrel2-handler.cabal view
@@ -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
src/Mongrel2.hs view
@@ -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.
src/Mongrel2/Parser.hs view
@@ -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)
src/Mongrel2/Types.hs view
@@ -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)