{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hack2.Handler.Mongrel2HTTP
(
runWithConfig
, ServerConfig(..)
, Types.Handler(..)
) where
import Prelude ()
import Air.Env hiding (def, Default, log)
import Hack2
import Data.Default (def, Default)
import qualified Data.CaseInsensitive as CaseInsensitive
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 qualified Data.Enumerator.List as EL
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteString)
import Data.Maybe (listToMaybe, fromMaybe, isJust, fromJust)
import Data.Map (toAscList, fromAscList)
import Data.IORef (readIORef)
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 qualified Control.Exception as Exception
import System.IO (hPutStr, stderr)
import System.Posix.Signals
import Control.Concurrent
import Control.Concurrent.MVar
import System.Exit (exitSuccess)
import qualified Data.Map as Map
import Blaze.Text.Int (integral)
import Data.Monoid
import qualified Data.Aeson as Aeson
import Data.Text.Encoding (encodeUtf8)
import Safe (readMay, readDef)
import Control.Concurrent
import System.IO.Unsafe (unsafePerformIO)
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 =
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))
_ -> []
_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 ()
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 ())
runWithConfig :: ServerConfig -> Application -> IO ()
runWithConfig config app = do
exit_indicator <- newEmptyMVar
installHandler sigINT (Catch (exit_handler exit_indicator)) Nothing
threads <- [1..config.number_of_application_instances] .mapM (\instance_id ->
forkIO - server_safe_loop instance_id
)
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 = do
forever - do
Exception.catch (loop instance_id (config.handler) app) - \e ->
log - "Mongrel2 server error: " + (e :: Exception.SomeException).show + "\n"
loop :: Int -> Mongrel2.Handler -> Application -> IO ()
loop instance_id _handler app = do
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
app_response <- app - requestToEnv request
let { resposne =
Mongrel2.Response
{
Mongrel2.responseUuid = uuid
, Mongrel2.responseClientId = client_id
, Mongrel2.responseBody = make_response_enumerator app_response
}
}
Mongrel2.sendResponse connected_handler resposne