web-mongrel2 (empty) → 0.0.2
raw patch · 7 files changed
+406/−0 lines, 7 filesdep +HStringTemplatedep +basedep +bytestringsetup-changed
Dependencies added: HStringTemplate, base, bytestring, data-default, haskell98, json, mtl, old-time, parsec, system-uuid, template-haskell, zeromq-haskell
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Web/Mongrel2.hs +152/−0
- src/Web/Mongrel2/Parsing.hs +89/−0
- src/Web/Mongrel2/QQ.hs +10/−0
- src/Web/Mongrel2/Types.hs +87/−0
- web-mongrel2.cabal +36/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2011, Clint Moore+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Clint Moore nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Web/Mongrel2.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE QuasiQuotes #-}++-- |+-- Module: Web.Mongrel2+-- Copyright: (c) 2011 Clint Moore+-- License: BSD-style+-- 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.+--+-- > 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" }+-- > case m2_pull_socket conn of+-- > Nothing -> error "Didn't connect to Mongrel2!"+-- > Just sock ->+-- > forever $ poll sock >>=+-- > recv dumper bx >>+-- > return ()+-- > +-- > where+-- > dumper :: Request -> IO Response+-- > dumper req = do+-- > putStrLn req+-- > return $ defaultr req+-- >++module Web.Mongrel2 (+ M2(..)+ , Request(..)+ , Response(..)+ -- * Connection+ , connect+ , poll+ , recv+ -- * Utilities+ , defaultr+ ) where++import Control.Applicative+import qualified Data.ByteString.Char8 as BS+import Prelude hiding (lookup)+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 }+ +-- Request+-- UUID ID PATH SIZE:HEADERS,SIZE:BODY++-- Response+-- UUID SIZE:ID ID ID, BODY++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) []++-- | The receive action.+-- +recv :: (Request -> IO Response) -> M2 -> [Z.Poll] -> IO ()+recv handle pub ((Z.S s _):_ss) = do+ req <- Z.receive s []+ case m2_parse (BS.unpack req) of+ Left err -> error err+ Right rq -> do+ rsp <- handle rq+ case m2_publish_socket pub of+ Nothing -> error "Publish socket not connected?!"+ Just so -> send_response so rsp+recv _ _ _ = return ()++-- | Shortcut for @system-zeromq@'s poll function.+-- Interval is hardcoded to 1000000 ms.+poll :: Z.Socket a -> IO [Z.Poll]+poll sock =+ Z.poll [Z.S sock Z.InOut] 1000000++-- | Connects the internal sockets.+connect :: M2 -> IO M2+connect mong = do+ case ((,)+ <$> m2_publish_socket mong+ <*> m2_pull_socket mong ) of+ Just _ -> return mong+ Nothing -> do+ 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++ return $+ mong { m2_publish_socket = Just pub+ , m2_pull_socket = Just pull+ , m2_context = Just ctx+ , m2_uuid = Just uid+ }++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$++|]
+ src/Web/Mongrel2/Parsing.hs view
@@ -0,0 +1,89 @@++module Web.Mongrel2.Parsing (m2_parse) where++import Control.Applicative hiding (many)+import Text.ParserCombinators.Parsec hiding ((<|>))+import Data.Default+import Text.JSON+import Char (toLower)+import Web.Mongrel2.Types++m2_parse :: String -> Either String Request+m2_parse request =+ case parse request_split "" request of+ Right (uui,seqq,pat,blk) ->+ case request_env blk of+ Left e -> Left e+ Right req ->+ Right req { request_uuid = uui+ , request_id = seqq+ , request_path = pat }+ Left a -> Left $ show a+ where + request_split :: Parser (String,String,String,String)+ request_split = do+ uui <- many $ noneOf " "+ _ <- space+ iid <- many $ noneOf " "+ _ <- space+ path <- many $ noneOf " "+ _ <- space+ rest <- many anyToken+ + return (uui,iid,path,rest)+ + request_env :: String -> Either String Request+ request_env request_body =+ case parse qstr "" request_body of+ Left x -> Left $ 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+ + Right $ def { request_path = ml "PATH" json+ , request_method = ml "METHOD" json+ , request_version = ml "VERSION" json+ , request_uri = ml "URI" json+ , request_headers = unjs+ , request_pattern = ml "PATTERN" json+ , request_accept = ml "Accept" json+ , request_host = ml "Host" json+ , request_user_agent = ml "User-Agent" json+ , request_query_string = query_string_+ }+ + _ -> Left "error parsing the headers."+ ml :: String -> JSObject JSValue -> String+ ml k b = maybe "" id $ mlookup k b+ + qstr :: Parser (String,String)+ qstr = do+ n <- number+ _ <- char ':'+ x <- count n anyChar+ _ <- char ','+ nx <- number+ _ <- char ':'+ xy <- count nx anyChar+ + return (x,xy)++number :: Parser Int+number = do+ b <- many1 digit+ return $ read b++mlookup :: String -> JSObject JSValue -> Maybe String+mlookup key bndl =+ -- TODO: Not so sure that the alternate toLower is needed.+ mlookup' key bndl <|> mlookup' (map toLower key) bndl+ where+ mlookup' :: String -> JSObject JSValue -> Maybe String+ mlookup' k b = + case valFromObj k b of+ Ok v -> Just $ fromJSString v+ _ -> Nothing
+ src/Web/Mongrel2/QQ.hs view
@@ -0,0 +1,10 @@+{-# 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
@@ -0,0 +1,87 @@++module Web.Mongrel2.Types where++import Data.Default+import System.ZMQ++-- | An incoming request from the server.+data Request = Request {+ request_uuid :: String,+ request_path :: String,+ request_id :: String,+ + 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+ } deriving (Show)++-- | The response to send back.+data Response = Response {+ response_uuid :: String,+ response_id :: String,+ response_path :: String,+ + response_body :: String,+ response_headers :: [(String,String)],+ response_status :: String,+ response_charset :: String,+ response_content_type :: String,+ response_target :: Maybe String+ } deriving(Show)++-- | Internal connection data.+data M2 = M2 {+ m2_publish :: String,+ m2_publish_socket :: Maybe (Socket Pub),+ m2_pull :: String,+ m2_pull_socket :: Maybe (Socket Pull),+ m2_context :: Maybe Context,+ m2_uuid :: Maybe String+ }++instance Default M2 where+ def = M2 {+ m2_publish = def,+ m2_publish_socket = Nothing,+ m2_pull = def,+ m2_pull_socket = Nothing,+ m2_context = Nothing,+ m2_uuid = Nothing+ }++instance Default Request where+ def = Request {+ request_uuid = def,+ request_id = def,+ request_path = "/",+ + request_headers = def,+ request_method = def,+ request_version = def,+ request_uri = def,+ request_pattern = def,+ request_accept = def,+ request_host = def,+ request_query_string = def,+ request_user_agent = def+ }++instance Default Response where+ def = Response {+ response_id = def,+ response_uuid = def,+ response_path = "/",+ + response_charset = "UTF-8",+ response_content_type = "text/plain",+ response_body = def,+ response_headers = def,+ response_status = def,+ response_target = Nothing+ }
+ web-mongrel2.cabal view
@@ -0,0 +1,36 @@+name: web-mongrel2+version: 0.0.2+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++stability: unstable+homepage: http://github.com/cmoore/haskell-mongrel2+synopsis: Bindings for the Mongrel2 web server.+description: web-mongrel2 helps you write handlers for different frameworks.+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