hack2-handler-mongrel2-http 2011.6.22 → 2011.6.24
raw patch · 8 files changed
+348/−274 lines, 8 filesdep +stm
Dependencies added: stm
Files
- Nemesis +1/−1
- hack2-handler-mongrel2-http.cabal +4/−3
- readme.md +2/−2
- src/Hack2/Handler/Mongrel2.hs +0/−115
- src/Hack2/Handler/Mongrel2/IO.hs +174/−0
- src/Hack2/Handler/Mongrel2/Parser.hs +0/−91
- src/Hack2/Handler/Mongrel2/ResponseParser.hs +93/−0
- src/Hack2/Handler/Mongrel2HTTP.hs +74/−62
Nemesis view
@@ -26,7 +26,7 @@ task "i" (sh "ghci -isrc test/hello.hs") desc "run main"- task "run" (sh "runghc -isrc src/Hack2/Handler/Mongrel2HTTP.hs")+ task "run" (sh "runghc -isrc test/hello.hs") desc "test hello"
hack2-handler-mongrel2-http.cabal view
@@ -1,5 +1,5 @@ Name: hack2-handler-mongrel2-http-Version: 2011.6.22+Version: 2011.6.24 Build-type: Simple Synopsis: Hack2 Mongrel2 HTTP handler Description: Hack2 Mongrel2 HTTP handler@@ -35,12 +35,13 @@ , blaze-textual , unix , attoparsec+ , stm hs-source-dirs: src/ exposed-modules: Hack2.Handler.Mongrel2HTTP other-modules:- Hack2.Handler.Mongrel2- Hack2.Handler.Mongrel2.Parser+ Hack2.Handler.Mongrel2.IO+ Hack2.Handler.Mongrel2.ResponseParser Hack2.Handler.Mongrel2.Response Hack2.Handler.Mongrel2.Types
readme.md view
@@ -3,9 +3,9 @@ * enumerator enabled, constant memory consumption when enumerator all the way down -Know Issue+Known Issues ---------- * Server run loop is naive ><-* default start 10 instances, which might not be the right way to run mongrel2 apps+* default start 10 instances, might not be the best way to run Hack2 apps * Very early stage in development
− src/Hack2/Handler/Mongrel2.hs
@@ -1,115 +0,0 @@--- adopted from Bardur Arantsson's MIT mongrel2-handler---{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}----module Hack2.Handler.Mongrel2- ( - mkHandler- , withConnectedHandler- , receiveRequest- , sendResponse- -- Re-exported- , module Hack2.Handler.Mongrel2.Types- ) where--import Blaze.ByteString.Builder (Builder,fromByteString)-import Data.Attoparsec-import Hack2.Handler.Mongrel2.Parser (messageParser)-import Hack2.Handler.Mongrel2.Response-import Hack2.Handler.Mongrel2.Types-import qualified System.ZMQ as ZMQ-import Data.ByteString.Char8 (ByteString, unpack)-import Control.Monad (forM_)-import qualified Data.ByteString.Char8 as B--import Data.Enumerator-import Air.Env-import Prelude ()----- | Create a new handler. @mkHandler pullFromAddress publishToAddress id@--- creates a handler which pulls requests from @fromAddress@ and publishes--- replies to @publishAddress@.-mkHandler :: String -> String -> Maybe String -> Handler-mkHandler = Handler---- | Run an IO action with a connected handler.-withConnectedHandler :: Handler -> (ConnectedHandler -> IO a) -> IO a-withConnectedHandler h io =- ZMQ.withContext 1 - \c ->- ZMQ.withSocket c ZMQ.Pull - \s -> do- ZMQ.withSocket c ZMQ.Pub - \ps -> do- -- Connect to the poll socket.- ZMQ.connect s - handlerPullFrom h- -- Bind to publish socket.- ZMQ.connect ps - handlerPublishTo h- case handlerId h of- Nothing -> return ()- Just uuid -> ZMQ.setOption ps - ZMQ.Identity uuid- -- Run the action with the connected handler.- io - ConnectedHandler s ps---- | Receive a parsed request from the Mongrel2 server. Blocks until--- a message is received.-receiveRequest :: ConnectedHandler -> IO Request-receiveRequest handler = do- msg <- ZMQ.receive (chPullSocket handler) []- - -- putStrLn - "handler received: " + unpack msg- - -- Parse into a structured message.- case parseOnly messageParser msg of- Left errMsg ->- -- Invalid message. This can only happen if there's- -- an error in our parsing code or Mongrel2 itself.- fail - "Couldn't parse message: " + (show errMsg)- Right m -> do- -- Return the parsed message.- return m--sendResponse :: ConnectedHandler -> Response -> IO ()-sendResponse handler response = - run_ - _responseEnum $$ _send_iteratee- - where- uuid = responseUuid response- clientId = responseClientId response- _responseEnum = responseBody response- _mk_response msg = mkResponse uuid clientId msg- - _socket = chPublishSocket handler-- _send msg = ZMQ.send _socket (_mk_response msg) [] -- [ZMQ.SndMore]- _done = ZMQ.send _socket (_mk_response "") []- - -- head :: Monad m => Iteratee B.ByteString m (Maybe Word8)- -- head = continue loop where- -- loop (Chunks xs) = case BL.uncons (BL.fromChunks xs) of- -- Just (char, extra) -> yield (Just char) (toChunks extra)- -- Nothing -> head- -- loop EOF = yield Nothing EOF- -- - - _send_iteratee :: Iteratee ByteString IO ()- _send_iteratee = continue loop where- loop (Chunks xs) = do- io - xs.mapM_ (\msg -> do- -- puts - "send msg: " + msg.unpack- _send msg- )- _send_iteratee- - loop EOF = do- -- io - puts - "done"- io - _done- yield () EOF- - -- let combined = B.append _responseHeader _responseBody- -- putStrLn - "message: " + unpack combined- - -- ZMQ.send _socket combined []-
+ src/Hack2/Handler/Mongrel2/IO.hs view
@@ -0,0 +1,174 @@+-- adopted from Bardur Arantsson's MIT mongrel2-handler+++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++++module Hack2.Handler.Mongrel2.IO where++import Blaze.ByteString.Builder (Builder,fromByteString)+import Data.Attoparsec+import Hack2.Handler.Mongrel2.ResponseParser (messageParser)+import Hack2.Handler.Mongrel2.Response+import Hack2.Handler.Mongrel2.Types+import qualified System.ZMQ as ZMQ+import Data.ByteString.Char8 (ByteString, unpack)+import Control.Monad (forM_)+import qualified Data.ByteString.Char8 as B++import Data.Enumerator hiding (map)+import Air.Env hiding (log)+import Prelude ()+import Hack2.Handler.Mongrel2.Utils+import Data.Attoparsec+import Data.Aeson (Value(..), json)+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Aeson as Aeson+import Data.Maybe (listToMaybe, fromMaybe, isJust, fromJust)+import qualified Data.Map as Map++import Control.Concurrent.STM+import Data.Int+import qualified Data.Set as Set+++-- | Create a new handler. @mkHandler pullFromAddress publishToAddress id@+-- creates a handler which pulls requests from @fromAddress@ and publishes+-- replies to @publishAddress@.+mkHandler :: String -> String -> Maybe String -> Handler+mkHandler = Handler++-- | Run an IO action with a connected handler.+withConnectedHandler :: Handler -> (ConnectedHandler -> IO a) -> IO a+withConnectedHandler h io =+ ZMQ.withContext 1 - \c ->+ ZMQ.withSocket c ZMQ.Pull - \s -> do+ ZMQ.withSocket c ZMQ.Pub - \ps -> do+ -- Connect to the poll socket.+ ZMQ.connect s - handlerPullFrom h+ -- Bind to publish socket.+ ZMQ.connect ps - handlerPublishTo h+ case handlerId h of+ Nothing -> return ()+ Just uuid -> ZMQ.setOption ps - ZMQ.Identity uuid+ -- Run the action with the connected handler.+ io - ConnectedHandler s ps++-- | Receive a parsed request from the Mongrel2 server. Blocks until+-- a message is received.+receiveRequest :: ConnectedHandler -> IO Request+receiveRequest handler = do+ msg <- ZMQ.receive (chPullSocket handler) []+ + log - "ZeroMQ received: " + unpack msg+ + -- Parse into a structured message.+ case parseOnly messageParser msg of+ Left errMsg ->+ -- Invalid message. This can only happen if there's+ -- an error in our parsing code or Mongrel2 itself.+ fail - "Couldn't parse message: " + (show errMsg)+ Right m -> do+ -- Return the parsed message.+ return m++++jsonToList :: Value -> [(ByteString, ByteString)]+jsonToList value = + let + maybe_string (Aeson.String x) = Just - x+ maybe_string _ = Nothing+ + _headers = + case value of+ Aeson.Object headerMap -> + headerMap+ .Map.toAscList+ .map_snd maybe_string+ .select (snd > isJust)+ .map (\(x,y) -> (x.encodeUtf8, fromJust y.encodeUtf8))+ _ -> []+ in+ _headers++requestJsonBody :: Request -> Maybe [(ByteString, ByteString)]+requestJsonBody request = + let + _headers = request.requestHeaders.jsonToList+ _method = _headers.lookup "METHOD" .fromMaybe "JSON"+ in+ + if _method.is "JSON"+ then + let msg = request.requestBody+ in++ case parseOnly json - msg of+ Left errMsg ->+ -- Invalid message. This can only happen if there's+ -- an error in our parsing code or Mongrel2 itself.+ -- log_error - "Couldn't parse message: " + (show errMsg)+ Just []+ Right m -> do+ -- Return the parsed message.+ Just - m.jsonToList+ else+ Nothing+ ++sendResponse :: ConnectedHandler -> TVar (Set.Set Int64) -> Response -> IO ()+sendResponse handler disconnected response = + run_ - _responseEnum $$ _send_iteratee+ + where+ uuid = responseUuid response+ clientId = responseClientId response+ _responseEnum = responseBody response+ _mk_response msg = mkResponse uuid clientId msg+ + _socket = chPublishSocket handler++ -- if put SndMore, memory hogs at socket buffer+ _send msg = ZMQ.send _socket (_mk_response msg) [] -- [ZMQ.SndMore]+ + -- we don't need done, since according to HTTP, ocntent-length should always be set+ -- which causes connection to be auto disconnected+ _done = ZMQ.send _socket (_mk_response "") []+ + -- head :: Monad m => Iteratee B.ByteString m (Maybe Word8)+ -- head = continue loop where+ -- loop (Chunks xs) = case BL.uncons (BL.fromChunks xs) of+ -- Just (char, extra) -> yield (Just char) (toChunks extra)+ -- Nothing -> head+ -- loop EOF = yield Nothing EOF+ -- + + _send_iteratee :: Iteratee ByteString IO ()+ _send_iteratee = continue loop where+ loop (Chunks xs) = do+ + _ids <- io - atomically - readTVar disconnected+ + if _ids.has clientId+ then do+ io - log - "client disconnected, ignore rest of message"+ + else do+ xs.mapM_ (\msg -> do+ io - _send - msg+ -- io - log - "ZeroMQ sent: " + unpack msg+ )+ + _send_iteratee+ + loop EOF = do+ yield () EOF+ + -- let combined = B.append _responseHeader _responseBody+ -- putStrLn - "message: " + unpack combined+ + -- ZMQ.send _socket combined []+
− src/Hack2/Handler/Mongrel2/Parser.hs
@@ -1,91 +0,0 @@-module Hack2.Handler.Mongrel2.Parser- ( - messageParser- ) where--import Data.Aeson (Value(..), json)-import Data.Attoparsec-import Data.Attoparsec.Char8 (decimal)-import Data.ByteString (ByteString)-import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8)-import Data.Word (Word8)-import Prelude hiding (take)-import qualified Data.Map as M-import Hack2.Handler.Mongrel2.Types------ Predicates for parsing.-isSpace :: Word8 -> Bool-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---- Parse a UUID.-uuidParser :: Parser ByteString-uuidParser = takeWhile1 $ \w -> ((w >= 65) && (w <= 90 )) -- A-Z- || ((w >= 97) && (w <= 122)) -- a-z- || ((w >= 48) && (w <= 57 )) -- 0-9- || (w == 45) -- Dash- -- || (w == 95) -- _- - --netstringParser :: (Int -> Parser a) -> Parser a-netstringParser contentParser = do- len <- decimal- skip isColon- str <- contentParser len- return str---- mongrel_send 2 / 238:{"PATH":"/","x-forwarded-for":"127.0.0.1","accept":"*/*","user-agent":"curl/7.19.7 (universal-apple-darwin10.0) libcurl/7.19.7 OpenSSL/0.9.8l zlib/1.2.3","host":"127.0.0.1:6767","METHOD":"GET","VERSION":"HTTP/1.1","URI":"/","PATTERN":"/"},0:,---- def parse(msg):--- sender, conn_id, path, rest = msg.split(' ', 3)--- headers, rest = tnetstrings.parse(rest)--- body, _ = tnetstrings.parse(rest)--- --- if type(headers) is str:--- headers = json.loads(headers)--- --- return Request(sender, conn_id, path, headers, body)- -messageParser :: Parser Request-messageParser = do- uuid <- uuidParser- skipSpace- clientId <- decimal- skipSpace- path <- takeTill isSpace- skipSpace- reqHdr <- netstringParser $ \_ -> json- skip isComma- reqBody <- netstringParser take- - return $ Request - {- requestUuid = uuid- , requestClientId = clientId- , requestPath = path- , requestHeaders = reqHdr- , requestBody = reqBody- }---- extractQuery :: Value -> ([Text], Query)--- extractQuery (Object 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"
+ src/Hack2/Handler/Mongrel2/ResponseParser.hs view
@@ -0,0 +1,93 @@+module Hack2.Handler.Mongrel2.ResponseParser+ ( + messageParser+ ) where++import Data.Aeson (Value(..), json)+import Data.Attoparsec+import Data.Attoparsec.Char8 (decimal)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Data.Word (Word8)+import Prelude hiding (take)+import qualified Data.Map as M+import Hack2.Handler.Mongrel2.Types++++-- Predicates for parsing.+isSpace :: Word8 -> Bool+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++-- Parse a UUID.+uuidParser :: Parser ByteString+uuidParser = takeWhile1 $ \w -> ((w >= 65) && (w <= 90 )) -- A-Z+ || ((w >= 97) && (w <= 122)) -- a-z+ || ((w >= 48) && (w <= 57 )) -- 0-9+ || (w == 45) -- Dash+ -- || (w == 95) -- _+ + ++netstringParser :: (Int -> Parser a) -> Parser a+netstringParser contentParser = do+ len <- decimal+ skip isColon+ str <- contentParser len+ return str++-- mongrel_send 2 / 238:{"PATH":"/","x-forwarded-for":"127.0.0.1","accept":"*/*","user-agent":"curl/7.19.7 (universal-apple-darwin10.0) libcurl/7.19.7 OpenSSL/0.9.8l zlib/1.2.3",+-- "host":"127.0.0.1:6767","METHOD":"GET","VERSION":"HTTP/1.1","URI":"/","PA+-- TTERN":"/"},0:,++-- def parse(msg):+-- sender, conn_id, path, rest = msg.split(' ', 3)+-- headers, rest = tnetstrings.parse(rest)+-- body, _ = tnetstrings.parse(rest)+-- +-- if type(headers) is str:+-- headers = json.loads(headers)+-- +-- return Request(sender, conn_id, path, headers, body)+ +messageParser :: Parser Request+messageParser = do+ uuid <- uuidParser+ skipSpace+ clientId <- decimal+ skipSpace+ path <- takeTill isSpace+ skipSpace+ reqHdr <- netstringParser $ \_ -> json+ skip isComma+ reqBody <- netstringParser take+ + return $ Request + {+ requestUuid = uuid+ , requestClientId = clientId+ , requestPath = path+ , requestHeaders = reqHdr+ , requestBody = reqBody+ }++-- extractQuery :: Value -> ([Text], Query)+-- extractQuery (Object 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"
src/Hack2/Handler/Mongrel2HTTP.hs view
@@ -8,7 +8,7 @@ runWithConfig , ServerConfig(..)-, Types.Handler(..)+, Mongrel2.Handler(..) ) where import Prelude ()@@ -31,9 +31,8 @@ import System.Directory (createDirectory, doesDirectoryExist) import Control.Monad (when, forever) -import qualified Hack2.Handler.Mongrel2 as Mongrel2--import qualified Hack2.Handler.Mongrel2.Types as Types+import Hack2.Handler.Mongrel2.IO+import qualified Hack2.Handler.Mongrel2.Types as Mongrel2 import qualified Control.Exception as Exception import System.IO (hPutStr, stderr)@@ -50,10 +49,14 @@ import Data.Text.Encoding (encodeUtf8) import Safe (readMay, readDef) -import Control.Concurrent-import System.IO.Unsafe (unsafePerformIO)+import Hack2.Handler.Mongrel2.Utils+import Data.Attoparsec+import Data.Aeson (Value(..), json) - +import Control.Concurrent.STM+import Data.Int+import qualified Data.Set as Set+ buildSpace :: Builder buildSpace = fromByteString " " @@ -115,21 +118,14 @@ -- , hackHeaders :: [(ByteString, ByteString)] + requestToEnv :: Mongrel2.Request -> Env requestToEnv request = let maybe_string (Aeson.String x) = Just - x maybe_string _ = Nothing - _headers = - case request.Mongrel2.requestHeaders of- Aeson.Object headerMap -> - headerMap- .Map.toAscList- .map_snd maybe_string- .select (snd > isJust)- .map (\(x,y) -> (x.encodeUtf8, fromJust y.encodeUtf8))- _ -> []+ _headers = request.Mongrel2.requestHeaders.jsonToList _host = _headers.lookup "host" .fromMaybe "" _query = _headers.lookup "QUERY" .fromMaybe ""@@ -149,17 +145,16 @@ _input_enum = enumList 1 [request.Mongrel2.requestBody] in- - def- {- requestMethod = ( _headers.lookup "METHOD" >>= B.unpack > readMay ).fromMaybe GET- , pathInfo = request.Mongrel2.requestPath- , queryString = _query- , serverName = _host.B.takeWhile (is_not ':')- , serverPort = _host.B.dropWhile (is_not ':') .B.dropWhile (is ':') .B.unpack.readDef 80- , httpHeaders = _http_headers- , hackInput = HackEnumerator _input_enum- }+ def+ {+ requestMethod = ( _headers.lookup "METHOD" >>= B.unpack > readMay ).fromMaybe GET+ , pathInfo = request.Mongrel2.requestPath+ , queryString = _query+ , serverName = _host.B.takeWhile (is_not ':')+ , serverPort = _host.B.dropWhile (is_not ':') .B.dropWhile (is ':') .B.unpack.readDef 80+ , httpHeaders = _http_headers+ , hackInput = HackEnumerator _input_enum+ } @@ -232,18 +227,10 @@ log "Exiting..." putMVar exit_indicator () -sync_lock :: MVar ()-sync_lock = unsafePerformIO - newMVar () -jailed :: IO a -> IO a-jailed io = do- withMVar sync_lock (const io) -- log :: String -> IO ()--- log x = jailed (putStrLn x)--log :: String -> IO ()-log = const (return ())+-- log = const (return ()) runWithConfig :: ServerConfig -> Application -> IO ()@@ -251,9 +238,11 @@ exit_indicator <- newEmptyMVar installHandler sigINT (Catch (exit_handler exit_indicator)) Nothing-+ + disconnected <- newTVarIO def+ threads <- [1..config.number_of_application_instances] .mapM (\instance_id -> - forkIO - server_safe_loop instance_id+ forkIO - server_safe_loop instance_id disconnected ) log "taking exit_indicator"@@ -270,37 +259,60 @@ -- log "all threads killed" -- log "Mongrel2 main will exist" ++ where- server_safe_loop instance_id = do+ server_safe_loop instance_id disconnected = do forever - do- Exception.catch (loop instance_id (config.handler) app) - \e ->- log - "Mongrel2 server error: " + (e :: Exception.SomeException).show + "\n"+ catch_all "ZeroMQ error:" - loop instance_id (config.handler) disconnected app +catch_all :: String -> IO () -> IO ()+catch_all message io_action = + Exception.catch io_action - \e ->+ log_error - message + " " + (e :: Exception.SomeException).show + "\n"+ + +loop :: Int -> Mongrel2.Handler -> TVar (Set.Set Int64) -> Application -> IO ()+loop instance_id _handler disconnected app = do + withConnectedHandler _handler - \connected_handler -> do -loop :: Int -> Mongrel2.Handler -> Application -> IO ()-loop instance_id _handler app = do+ -- catch_all "Hack2 Application error:" - do+ + log - "instance " + show instance_id + " waiting ..."+ request <- receiveRequest connected_handler+ + log - "instance " + show instance_id + " handling ..."+ -- putStrLn - "instance " + show instance_id + " handling ..." - Mongrel2.withConnectedHandler _handler - \connected_handler -> do- log - "instance " + show instance_id + " waiting ..."- request <- Mongrel2.receiveRequest connected_handler- log - "instance " + show instance_id + " handling ..."- -- putStrLn - "instance " + show instance_id + " handling ..."- - let uuid = request.Mongrel2.requestUuid- client_id = request.Mongrel2.requestClientId+ let uuid = request.Mongrel2.requestUuid+ client_id = request.Mongrel2.requestClientId+ + json_request = request.requestJsonBody+ + case json_request of+ Nothing -> do+ app_response <- app - requestToEnv request - app_response <- app - requestToEnv request- - let { resposne = - Mongrel2.Response- {- Mongrel2.responseUuid = uuid- , Mongrel2.responseClientId = client_id- , Mongrel2.responseBody = make_response_enumerator app_response- }- }+ let { resposne = + Mongrel2.Response+ {+ Mongrel2.responseUuid = uuid+ , Mongrel2.responseClientId = client_id+ , Mongrel2.responseBody = make_response_enumerator app_response+ }+ } - Mongrel2.sendResponse connected_handler resposne+ sendResponse connected_handler disconnected resposne+ Just xs -> do+ case xs.lookup "type" of+ Just "disconnect" -> do+ log - "client " + show client_id + " disconnected"+ atomically - do+ _ids <- readTVar disconnected+ writeTVar disconnected - _ids.Set.insert client_id+ + _ ->+ log - "json reponse: " + show xs