{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hack2.Handler.Mongrel2HTTP
(
runWithConfig
, ServerConfig(..)
, Mongrel2.Handler(..)
) where
import Prelude ()
import Air.Env hiding (def, Default, log)
import Hack2
import Data.Default (def, Default)
import Data.ByteString.Char8 (ByteString, pack)
import qualified Data.ByteString.Char8 as B
import Data.Enumerator (Enumerator, Iteratee (..), ($$), joinI, run_, Enumeratee, Step, (=$), ($=), enumList, concatEnums)
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteString)
import Data.Maybe (listToMaybe, fromMaybe, isJust, fromJust)
import Data.Map (toAscList, fromAscList)
import Control.Monad (when, forever)
import Hack2.Handler.Mongrel2.IO
import qualified Hack2.Handler.Mongrel2.Types as Mongrel2
import qualified Control.Exception as Exception
import System.IO (hPutStr, stderr)
import System.Posix.Signals
import Control.Concurrent
import qualified Data.Map as Map
import Blaze.Text.Int (integral)
import Data.Monoid
import qualified Data.Aeson as Aeson
import Safe (readMay, readDef)
import Hack2.Handler.Mongrel2.Utils
import Control.Concurrent.STM
import Data.Int
import qualified Data.Set as Set
import qualified Data.List as List
import qualified Prelude as P
buildSpace :: Builder
buildSpace = fromByteString " "
buildNewLine :: Builder
buildNewLine = fromByteString "\r\n"
make_response_enumerator :: Response -> Enumerator ByteString IO a
make_response_enumerator response =
concatEnums
[
header_enum
, response.body.unHackEnumerator
]
where
header_enum = enumList 1 - return - make_response_header - response
make_response_header :: Response -> ByteString
make_response_header response =
[
fromByteString "HTTP/1.1"
, buildSpace
, integral - response.status
, buildSpace
, fromByteString - (statusReasonMap.Map.lookup (response.status) .fromMaybe "Unknown Status Code")
, buildNewLine
, mconcat - response.headers.map build_header
, buildNewLine
]
.mconcat
.toByteString
where
build_header :: (ByteString, ByteString) -> Builder
build_header (header, value) =
[
fromByteString header
, fromByteString ": "
, fromByteString value
, buildNewLine
]
.mconcat
-- example json request string
-- {"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":"/"}
-- { requestMethod :: RequestMethod
-- , scriptName :: ByteString
-- , pathInfo :: ByteString
-- , queryString :: ByteString
-- , serverName :: ByteString
-- , serverPort :: Int
-- , httpHeaders :: [(ByteString, ByteString)]
-- , hackVersion :: (Int, Int, Int)
-- , hackUrlScheme :: HackUrlScheme
-- , hackInput :: HackEnumerator
-- , hackErrors :: HackErrors
-- , hackHeaders :: [(ByteString, ByteString)]
requestToEnv :: Mongrel2.Request -> Env
requestToEnv request =
let
maybe_string (Aeson.String x) = Just - x
maybe_string _ = Nothing
_headers = request.Mongrel2.requestHeaders.jsonToList
_host = _headers.lookup "host" .fromMaybe ""
_query = _headers.lookup "QUERY" .fromMaybe ""
_mongrel2_header_names =
[
"PATH"
, "host"
, "METHOD"
, "VERSION"
]
_http_headers = _headers
_input_enum :: (forall a . Enumerator ByteString IO a)
_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
}
-- copied from snap-core
statusReasonMap :: Map.Map Int ByteString
statusReasonMap = Map.fromAscList [
(100, "Continue"),
(101, "Switching Protocols"),
(200, "OK"),
(201, "Created"),
(202, "Accepted"),
(203, "Non-Authoritative Information"),
(204, "No Content"),
(205, "Reset Content"),
(206, "Partial Content"),
(300, "Multiple Choices"),
(301, "Moved Permanently"),
(302, "Found"),
(303, "See Other"),
(304, "Not Modified"),
(305, "Use Proxy"),
(307, "Temporary Redirect"),
(400, "Bad Request"),
(401, "Unauthorized"),
(402, "Payment Required"),
(403, "Forbidden"),
(404, "Not Found"),
(405, "Method Not Allowed"),
(406, "Not Acceptable"),
(407, "Proxy Authentication Required"),
(408, "Request Time-out"),
(409, "Conflict"),
(410, "Gone"),
(411, "Length Required"),
(412, "Precondition Failed"),
(413, "Request Entity Too Large"),
(414, "Request-URI Too Large"),
(415, "Unsupported Media Type"),
(416, "Requested range not satisfiable"),
(417, "Expectation Failed"),
(500, "Internal Server Error"),
(501, "Not Implemented"),
(502, "Bad Gateway"),
(503, "Service Unavailable"),
(504, "Gateway Time-out"),
(505, "HTTP Version not supported")
]
--
data ServerConfig = ServerConfig
{
handler :: Mongrel2.Handler
, number_of_application_instances :: Int
}
instance Default ServerConfig where
def = ServerConfig
{
handler = def
, number_of_application_instances = 10
}
exit_handler :: MVar () -> IO ()
exit_handler exit_indicator = do
log "Exiting..."
putMVar exit_indicator ()
-- log :: String -> IO ()
-- log = const (return ())
runWithConfig :: ServerConfig -> Application -> IO ()
runWithConfig config app = do
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 disconnected
)
fork - forever - clean_up_disconnected_client_ids disconnected
log "taking exit_indicator"
takeMVar exit_indicator
log "done taking exit_indicator"
-- log "killing threads ..."
-- threads.mapM_ killThread
--
-- log "waiting threads termination ..."
-- sleep 2
--
-- log "all threads killed"
-- log "Mongrel2 main will exist"
where
server_safe_loop instance_id disconnected = do
forever - do
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"
clean_up_disconnected_client_ids :: TVar (Set.Set Int64) -> IO ()
clean_up_disconnected_client_ids disconnected = do
sleep 10
atomically - do
ids <- readTVar disconnected
let set_length = ids.Set.size
max_length = 10000
when (set_length >= max_length) - do
let new_ids = ids.to_list.List.sort.drop (set_length P.- max_length).Set.fromList
writeTVar disconnected new_ids
loop :: Int -> Mongrel2.Handler -> TVar (Set.Set Int64) -> Application -> IO ()
loop instance_id _handler disconnected app = do
withConnectedHandler _handler - \connected_handler -> 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 ..."
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
let { resposne =
Mongrel2.Response
{
Mongrel2.responseUuid = uuid
, Mongrel2.responseClientId = client_id
, Mongrel2.responseBody = make_response_enumerator app_response
}
}
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_error - "Unknown json reponse: " + request.Mongrel2.requestBody.B.unpack