web-mongrel2 0.0.2.2 → 0.0.3
raw patch · 7 files changed
+205/−154 lines, 7 filesdep +file-embeddep +textdep ~zeromq-haskell
Dependencies added: file-embed, text
Dependency ranges changed: zeromq-haskell
Files
- response_template.st +10/−0
- src/Text/Parsec/Text.hs +18/−0
- src/Web/Mongrel2.hs +47/−55
- src/Web/Mongrel2/Parsing.hs +40/−28
- src/Web/Mongrel2/QQ.hs +0/−10
- src/Web/Mongrel2/Types.hs +58/−35
- web-mongrel2.cabal +32/−26
+ response_template.st view
@@ -0,0 +1,10 @@+$uuid$ $idl$:$id$, HTTP/1.1 $status$ OK+Content-Type: $contenttype$; charset=$charset$+Connection: close+Content-Length: $clen$+Server: Mongrel2+Date: $now$+$headers:{a|$a.0$:$a.1$+}$++$body$
+ src/Text/Parsec/Text.hs view
@@ -0,0 +1,18 @@++{-# LANGUAGE FlexibleInstances,+ MultiParamTypeClasses,+ NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.Parsec.Text ( module Text.Parsec.Char, Parser, GenParser ) where++import Text.Parsec.Prim+import Text.Parsec.Char+import qualified Data.Text as T++instance (Monad m) => Stream T.Text m Char where+ uncons = return . T.uncons++type Parser = Parsec T.Text ()+type GenParser t st = Parsec T.Text st+
src/Web/Mongrel2.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-} -- | -- Module: Web.Mongrel2@@ -7,28 +7,27 @@ -- Maintainer: cmoore@wamboli.com -- Stability: experimental -- Portability: GHC--- --- +--+-- -- A simple abstraction for applications to use Mongrel2. -- Mongrel2 is simple and easy to use, and hopefully others -- find this module almost as easy.--- --- Please direct any questions or comments, and /especially/ criticism to my email. This is my first release to hackage and I'm very interested in how I can improve. -- -- > require Web.Mongrel2 -- > require Control.Monad (forever)--- > +-- > -- > main :: IO () -- > main = do -- > conn <- connect $ def { m2_publish = "tcp://127.0.0.1:9996--- > , m2_pull = "tcp://127.0.0.1:9997" }+-- > , m2_pull = "tcp://127.0.0.1:9997"+-- > , m2_uuid = "my-awesome-webapp" } -- > case m2_pull_socket conn of -- > Nothing -> error "Didn't connect to Mongrel2!" -- > Just sock -> -- > forever $ poll sock >>=--- > recv dumper bx >>+-- > recv dumper conn >> -- > return ()--- > +-- > -- > where -- > dumper :: Request -> IO Response -- > dumper req = do@@ -37,37 +36,36 @@ -- > module Web.Mongrel2 (- M2(..)- , Request(..)- , Response(..) -- * Connection- , connect+ connect , poll , recv -- * Utilities , defaultr ) where +import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+ import Control.Applicative import qualified Data.ByteString.Char8 as BS-import Prelude hiding (lookup)+import Data.Default (def)+import Data.FileEmbed (embedFile) import System.Time (getClockTime) import qualified System.ZMQ as Z import Text.StringTemplate import Web.Mongrel2.Parsing-import Web.Mongrel2.QQ (qq) import Web.Mongrel2.Types -import Data.Default (def)- -- | Generate a 'Response' from the 'Request' copying sane defaults. defaultr :: Request -> Response defaultr req = def { response_uuid = request_uuid req , response_id = request_id req- , response_path = request_path req }- + , response_path = request_path req + , response_headers = request_headers req }+ -- Request -- UUID ID PATH SIZE:HEADERS,SIZE:BODY @@ -77,28 +75,33 @@ send_response :: Z.Socket a -> Response -> IO () send_response sock resp = do now <- getClockTime- Z.send sock (BS.pack $ render $- setAttribute "headers" (response_headers resp) $- setManyAttrib [("id", (response_id resp)),- ("uuid", (response_uuid resp)),- ("idl", (show $ length $ response_id resp)),- ("now", (show now)),- ("clen", (show $ length $ response_body resp)),- ("sep", "\r\n"),- ("status", response_status resp),- ("contenttype", response_content_type resp),- ("charset", response_charset resp),- ("body",(response_body resp))] $- newSTMP response_template) []+ -- TODO: Why the hell do I have to do this?+ -- TODO: Otherwise, every response is missing one character.+ let leng = (T.length $ response_body resp) + 1+ + let res = BS.pack $+ render $+ setAttribute "headers" (response_headers resp) $+ setManyAttrib [("id", (response_id resp)),+ ("uuid", (response_uuid resp)),+ ("idl", (T.pack $ show $ T.length $ response_id resp)),+ ("now", (T.pack $ show now)),+ ("clen", T.pack $ show leng),+ ("sep", T.pack "\r\n"),+ ("status", response_status resp),+ ("contenttype", response_content_type resp),+ ("charset", response_charset resp),+ ("body",(response_body resp))] $+ newSTMP response_template+ Z.send sock res [] -- | The receive action.--- +-- recv :: (Request -> IO Response) -> M2 -> [Z.Poll] -> IO () recv handle pub ((Z.S s _):_ss) = do req <- Z.receive s []- putStrLn $ "REQ:\n" ++ (show req)- case m2_parse (BS.unpack req) of- Left err -> error err+ case m2_parse (TE.decodeUtf8 req) of+ Left err -> error $ T.unpack err Right rq -> do rsp <- handle rq case m2_publish_socket pub of@@ -123,16 +126,16 @@ ctx <- Z.init 1 pub <- Z.socket ctx Z.Pub pull <- Z.socket ctx Z.Pull- + let uid = case m2_uuid mong of Just v -> v- Nothing -> "82209006-86GF-4982-B5EA-D1E29E55D481"- - Z.connect pull $ m2_pull mong- Z.setOption pull $ Z.Identity uid- - Z.connect pub $ m2_publish mong+ Nothing -> T.pack "82209006-86GF-4982-B5EA-D1E29E55D481" + Z.connect pull $ T.unpack $ m2_pull mong+ Z.setOption pull $ Z.Identity $ T.unpack uid++ Z.connect pub $ T.unpack $ m2_publish mong+ return $ mong { m2_publish_socket = Just pub , m2_pull_socket = Just pull@@ -141,15 +144,4 @@ } response_template :: String-response_template = [$qq|$uuid$ $idl$:$id$, HTTP/1.1 $status$ OK-Content-Type: $contenttype$; charset=$charset$-Connection: close-Content-Length: $clen$-Server: Mongrel2-Date: $now$-$headers:{a|$a.0$:$a.1$-}$--$body$--|]+response_template = BS.unpack $(embedFile "response_template.st")
src/Web/Mongrel2/Parsing.hs view
@@ -1,14 +1,16 @@-+{-# LANGUAGE OverloadedStrings #-} module Web.Mongrel2.Parsing (m2_parse) where +import qualified Data.Text as T import Control.Applicative hiding (many)-import Text.ParserCombinators.Parsec hiding ((<|>))+import Text.Parsec.Text+import Text.Parsec hiding ((<|>)) import Data.Default-import Text.JSON-import Char (toLower)+import qualified Text.JSON as JS+ import Web.Mongrel2.Types -m2_parse :: String -> Either String Request+m2_parse :: T.Text -> Either T.Text Request m2_parse request = case parse request_split "" request of Right (uui,seqq,pat,blk) ->@@ -18,9 +20,9 @@ Right req { request_uuid = uui , request_id = seqq , request_path = pat }- Left a -> Left $ show a+ Left a -> Left $ T.pack $ show a where - request_split :: Parser (String,String,String,String)+ request_split :: Parser (T.Text,T.Text,T.Text,T.Text) request_split = do uui <- many $ noneOf " " _ <- space@@ -30,22 +32,25 @@ _ <- space rest <- many anyToken - return (uui,iid,path,rest)+ return (T.pack uui,T.pack iid,T.pack path,T.pack rest) - request_env :: String -> Either String Request+ request_env :: T.Text -> Either T.Text Request request_env request_body = case parse qstr "" request_body of- Left x -> Left $ show x+ Left x -> Left $ T.pack $ show x Right (headers_,query_string_) ->- case decode headers_ of- Ok (JSObject json) -> do- let unjs = concat $- map (\(x,JSString y) -> do- [(x,fromJSString y)]- ) $ fromJSObject json+ case JS.decode (T.unpack headers_) of+ JS.Ok (JS.JSObject json) -> do+ let unjs =+ concat $+ map (\(x,y') ->+ case y' of+ JS.JSString y -> [(T.pack x,T.pack $ JS.fromJSString y)]+ _ -> []+ ) $ JS.fromJSObject json Right $ def { request_path = ml "PATH" json- , request_method = ml "METHOD" json+ , request_method = string_to_method $ ml "METHOD" json , request_version = ml "VERSION" json , request_uri = ml "URI" json , request_headers = unjs@@ -57,10 +62,10 @@ } _ -> Left "error parsing the headers."- ml :: String -> JSObject JSValue -> String+ ml :: T.Text -> JS.JSObject JS.JSValue -> T.Text ml k b = maybe "" id $ mlookup k b - qstr :: Parser (String,String)+ qstr :: Parser (T.Text,T.Text) qstr = do n <- number _ <- char ':'@@ -70,20 +75,27 @@ _ <- char ':' xy <- count nx anyChar - return (x,xy)+ return (T.pack x,T.pack xy) number :: Parser Int-number = do- b <- many1 digit- return $ read b+number = many1 digit >>= (return . read) -mlookup :: String -> JSObject JSValue -> Maybe String+mlookup :: T.Text -> JS.JSObject JS.JSValue -> Maybe T.Text mlookup key bndl = -- TODO: Not so sure that the alternate toLower is needed.- mlookup' key bndl <|> mlookup' (map toLower key) bndl+ mlookup' key bndl <|> mlookup' (T.toLower key) bndl where- mlookup' :: String -> JSObject JSValue -> Maybe String+ mlookup' :: T.Text -> JS.JSObject JS.JSValue -> Maybe T.Text mlookup' k b = - case valFromObj k b of- Ok v -> Just $ fromJSString v+ case JS.valFromObj (T.unpack k) b of+ JS.Ok v -> Just $ T.pack $ JS.fromJSString v _ -> Nothing++string_to_method :: T.Text -> RequestMethod+string_to_method "GET" = GET+string_to_method "POST" = POST+string_to_method "PUT" = PUT+string_to_method "DELETE" = DELETE+string_to_method "HEAD" = HEAD+string_to_method lx = error $ "Unknown method: " ++ T.unpack lx+
− src/Web/Mongrel2/QQ.hs
@@ -1,10 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-}--module Web.Mongrel2.QQ (qq) where--import Language.Haskell.TH.Quote-import Language.Haskell.TH.Lib--qq :: QuasiQuoter-qq = QuasiQuoter (litE . stringL) (litP . stringL)
src/Web/Mongrel2/Types.hs view
@@ -1,71 +1,94 @@-+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Web.Mongrel2.Types where import Data.Default import System.ZMQ+import qualified Data.Text as T +data RequestMethod = POST+ | GET+ | HEAD+ | PUT+ | DELETE++instance Show RequestMethod where+ show POST = "POST"+ show GET = "GET"+ show HEAD = "HEAD"+ show PUT = "PUT"+ show DELETE = "DELETE"++instance Default RequestMethod where+ def = GET+ +instance Default T.Text where+ def = ""+ -- | An incoming request from the server. data Request = Request { -- | The uuid of the server.- request_uuid :: String,+ request_uuid :: T.Text, -- | The path as passed in from Mongrel2.- request_path :: String,+ request_path :: T.Text, -- | The individual request id.- request_id :: String,- + request_id :: T.Text,+ -- | Any headers passed in from the server are copied to here.- request_headers :: [(String,String)],- request_method :: String,- request_version :: String,- request_uri :: String,- request_pattern :: String,- request_accept :: String,- request_host :: String,- request_query_string :: String,- request_user_agent :: String+ request_headers :: [(T.Text,T.Text)],+ request_method :: RequestMethod,+ request_version :: T.Text,+ request_uri :: T.Text,+ request_pattern :: T.Text,+ request_accept :: T.Text,+ request_host :: T.Text,+ request_query_string :: T.Text,+ request_user_agent :: T.Text } deriving (Show) -- | The response to send back. -- 'response_uuid', 'response_id', and 'response_path' are passed from the request and are needed for the response back to Mongrel2. data Response = Response { -- | The uuid of the server.- response_uuid :: String,+ response_uuid :: T.Text, -- | The request id.- response_id :: String,+ response_id :: T.Text, -- | The request path.- response_path :: String,- + response_path :: T.Text,+ -- | This is for, for example, cookies.- -- - -- > def { + --+ -- > def { -- > response_headers = [("cookies","uid=10239120192")] -- > }- -- + -- -- Of course, they will need to be encoded, etc. -- May I be so bold as to suggest @Web.Encodings@ ? :) - -- - response_headers :: [(String,String)],- + --+ response_headers :: [(T.Text,T.Text)],+ -- | 404, 302, etc.- response_status :: String,+ response_status :: T.Text, -- | Defaults to UTF-8- response_charset :: String,+ response_charset :: T.Text, -- | Defaults to text/plain- response_content_type :: String,- response_body :: String- } deriving(Show)+ response_content_type :: T.Text,+ response_body :: T.Text+ } deriving (Show) --- | Internal connection data. +-- | Internal connection data. -- 'm2_publish' and 'm2_pull' can be any ZeroMQ type that Mongrel2 supports. data M2 = M2 { -- | The address to connect for replies back to Mongrel2.- m2_publish :: String,+ m2_publish :: T.Text, m2_publish_socket :: Maybe (Socket Pub), -- | The address to poll for requests.- m2_pull :: String,+ m2_pull :: T.Text, m2_pull_socket :: Maybe (Socket Pull), m2_context :: Maybe Context,- m2_uuid :: Maybe String+ -- | The application identifier.+ -- This defaults to a standard uuid, but you probably want to supply your own.+ m2_uuid :: Maybe T.Text } instance Default M2 where@@ -83,7 +106,7 @@ request_uuid = def, request_id = def, request_path = "/",- + request_headers = def, request_method = def, request_version = def,@@ -100,7 +123,7 @@ response_id = def, response_uuid = def, response_path = "/",- + response_charset = "UTF-8", response_content_type = "text/plain", response_headers = def,
web-mongrel2.cabal view
@@ -1,36 +1,42 @@ name: web-mongrel2-version: 0.0.2.2+version: 0.0.3 build-type: Simple license: BSD3 license-file: LICENSE-maintainer: Clint Moore <cmoore@wamboli.com>--build-depends:- base >= 3 && <= 5,- bytestring -any,- data-default -any,- json -any,- parsec -any,- system-uuid -any,- mtl >= 2,- old-time,- haskell98,- zeromq-haskell == 0.4.1,- template-haskell -any,- HStringTemplate-+maintainer: Clint Moore <clint@ivy.io> stability: unstable homepage: http://github.com/cmoore/web-mongrel2 synopsis: Bindings for the Mongrel2 web server. description: A simple handler API for Mongrel2. category: Web author: Clint Moore-exposed-modules:- Web.Mongrel2,- Web.Mongrel2.QQ,- Web.Mongrel2.Types,- Web.Mongrel2.Parsing-exposed: True-buildable: True-ghc-options: -Wall-hs-source-dirs: src+cabal-version: >= 1.6+extra-source-files: response_template.st++source-repository head+ type: git+ location: git://github.com/cmoore/web-mongrel2.git++library+ ghc-options: -Wall+ hs-source-dirs: src+ build-depends:+ base >= 3 && <= 5,+ bytestring -any,+ data-default -any,+ json -any,+ parsec -any,+ system-uuid -any,+ mtl >= 2,+ old-time,+ haskell98,+ zeromq-haskell,+ template-haskell -any,+ HStringTemplate,+ file-embed,+ text+ exposed-modules:+ Web.Mongrel2,+ Web.Mongrel2.Types,+ Web.Mongrel2.Parsing,+ Text.Parsec.Text