mongrel2-handler 0.1.2 → 0.2.0
raw patch · 3 files changed
+110/−44 lines, 3 filesdep −aeson
Dependencies removed: aeson
Files
- mongrel2-handler.cabal +7/−3
- src/Mongrel2/Parser.hs +28/−41
- src/Mongrel2/Tnetstring.hs +75/−0
mongrel2-handler.cabal view
@@ -1,7 +1,11 @@ Name: mongrel2-handler-Version: 0.1.2+Version: 0.2.0 Synopsis: Mongrel2 Handler Library Description: Mongrel2 Handler Library.++ This handler library requires that the Mongrel2 server is set up+ to use the 'tnetstring' protocol.+ License: MIT License-file: LICENSE Category: Web@@ -13,7 +17,6 @@ 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@@ -27,6 +30,7 @@ Ghc-options: -Wall -fno-warn-unused-matches Hs-source-dirs: src Exposed-modules: Mongrel2- Mongrel2.Parser+ Other-modules: Mongrel2.Parser Mongrel2.Response Mongrel2.Types+ Mongrel2.Tnetstring
src/Mongrel2/Parser.hs view
@@ -4,16 +4,15 @@ , messageParser ) where -import Data.Aeson (Value(..), json) import Data.Attoparsec import Data.Attoparsec.Char8 (decimal)-import Data.ByteString (ByteString)+import Data.ByteString (ByteString, uncons) import Data.CaseInsensitive (CI) import Data.Map (Map) import Data.Maybe (catMaybes)-import Data.Text (Text, uncons)-import Data.Text.Encoding (encodeUtf8)+import Data.Text (Text) import Data.Word (Word8)+import Mongrel2.Tnetstring (parseTnetstring1, TValue(..)) import Mongrel2.Types (Request(..), UUID, ClientID) import Network.HTTP.Types (HttpVersion, Method, Query, RequestHeaders, decodePath, http09, http10, http11, parseMethod) import Prelude hiding (take)@@ -25,14 +24,6 @@ isSpace 0x20 = True isSpace _ = False -isColon :: Word8 -> Bool-isColon 0x3a = True-isColon _ = False--isComma :: Word8 -> Bool-isComma 0x2c = True-isComma _ = False- -- Skip spaces. skipSpace :: Parser () skipSpace = skipWhile isSpace@@ -44,13 +35,6 @@ ((w >= 48) && (w <= 57 )) || -- 0-9 (w == 45) -- Dash -netstringParser :: (Int -> Parser a) -> Parser a-netstringParser contentParser = do- len <- decimal- skip isColon- str <- contentParser len- return str- messageParser :: Parser Request messageParser = do uuid <- uuidParser@@ -59,51 +43,54 @@ skipSpace rawPath <- takeTill isSpace skipSpace- rawReqHdr <- netstringParser $ \_ -> json- skip isComma- body <- netstringParser take+ rawReqHdr <- parseTnetstring1+ rawBody <- parseTnetstring1 -- 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+ return $ Request path query rawPath method version (extractHeaders reqHdr) (extractBody rawBody) uuid clientId -unHeaders :: Value -> Map Text Value-unHeaders (Object m) = m-unHeaders _ = error "Invalid headers received from Mongrel2"+unHeaders :: TValue -> Map ByteString TValue+unHeaders (TDictionary m) = M.fromList m+unHeaders _ = error "Invalid headers received from Mongrel2" -extractQuery :: Map Text Value -> ([Text], Query)+extractBody :: TValue -> ByteString+extractBody (TString body) = body+extractBody _ = error "Invalid body received from Mongrel2"++extractQuery :: Map ByteString TValue -> ([Text], Query) extractQuery hdrs = case M.lookup "URI" hdrs of- Just (String uriText) -> decodePath $ encodeUtf8 uriText+ Just (TString uriText) -> decodePath uriText _ -> error "Missing/invalid 'URI' in headers received from Mongrel2" -extractMethod :: Map Text Value -> Method+extractMethod :: Map ByteString TValue -> Method extractMethod hdrs = case M.lookup "METHOD" hdrs of- Just (String methodText) -> encodeUtf8 methodText+ Just (TString methodText) -> methodText _ -> error "Missing/invalid 'METHOD' in headers received from Mongrel2" -extractVersion :: Map Text Value -> HttpVersion+extractVersion :: Map ByteString TValue -> 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 (TString "HTTP/0.9") -> http09+ Just (TString "HTTP/1.0") -> http10+ Just (TString "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 :: Map ByteString TValue -> 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+extractHdr :: (ByteString, TValue) -> Maybe (CI ByteString, ByteString)+extractHdr (t, TString v) = handleHdr t v+extractHdr _ = Nothing -handleHdr :: Text -> Text -> Maybe (CI ByteString, ByteString)+handleHdr :: ByteString -> ByteString -> 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)+ Just (c, _) | (c >= 65 && c <= 90) -> Nothing+ _ -> Just (CI.mk k, v)
+ src/Mongrel2/Tnetstring.hs view
@@ -0,0 +1,75 @@+module Mongrel2.Tnetstring+ ( parseTnetstring1+ , TValue(..)+ ) where++import Data.Attoparsec+import Data.Attoparsec.Char8 (decimal)+import Data.ByteString (ByteString)+import Data.Word (Word8)+import Prelude hiding (take)++isColon :: Word8 -> Bool+isColon 0x3a = True+isColon _ = False++data TValue = TInteger Integer+ | TString ByteString+ | TBoolean Bool+ | TList [TValue]+ | TDictionary [(ByteString, TValue)]+ | TNull+ deriving (Show)++subParse :: Parser a -> ByteString -> Parser a+subParse p s = do+ let x = parseOnly p s+ case x of+ Left err -> error err+ Right x' -> return x'++pString :: ByteString -> Parser TValue+pString s = return $ TString s++pInteger :: ByteString -> Parser TValue+pInteger s = fmap TInteger $ subParse decimal s++pBoolean :: ByteString -> Parser TValue+pBoolean "false" = return $ TBoolean False+pBoolean "true" = return $ TBoolean True+pBoolean _ = error "Invalid boolean literal"++pList :: ByteString -> Parser TValue+pList s = fmap TList $ subParse (many parseTnetstring1) s++pNull :: ByteString -> Parser TValue+pNull _ = return TNull++pDict :: ByteString -> Parser TValue+pDict s =+ fmap TDictionary $ subParse (many parsePair) s+ where+ parsePair :: Parser (ByteString,TValue)+ parsePair = do+ k' <- parseTnetstring1+ k'' <- case k' of+ TString k -> return k+ _ -> error "Dictionary keys may only be strings"+ v <- parseTnetstring1+ return $ (k'', v)++parseTnetstring1 :: Parser TValue+parseTnetstring1 = do+ n <- decimal+ skip isColon+ middle <- take n+ ctyp <- anyWord8+ value <- case ctyp of+ 0x2c -> pString middle+ 0x23 -> pInteger middle+ 0x21 -> pBoolean middle+ 0x7e -> pNull middle+ 0x5d -> pList middle+ 0x7d -> pDict middle+ _ -> error "Invalid type designation"+ return value