-- 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 []