{-# 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