{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ImpredicativeTypes #-}

module Hack.Handler.Hyena (run, runWithConfig, ServerConf(..)) where

import qualified Hack as Hack
import Hyena.Server
import Network.Wai as Wai
import qualified Hyena.Config as Hyena.Config

import Prelude hiding ((.), (^))
import System.IO
import Control.Monad

import Data.Default
import Data.Maybe
import Data.Char
import Control.Applicative ((<$>))
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M

import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (newChan,writeChan,getChanContents)

(.) :: a -> (a -> b) -> b
a . f = f a
infixl 9 .

data ServerConf = ServerConf { port :: Int, serverName :: String }
instance Default ServerConf where
  def = ServerConf { port = 3000, serverName = "localhost" }

unpack_tuple :: (S.ByteString, S.ByteString) -> (String, String)
unpack_tuple (x,y) = (C.unpack x, C.unpack y)

pack_tuple :: (String, String) -> (S.ByteString, S.ByteString)
pack_tuple (x,y) = (C.pack x, C.pack y)

hyena_env_to_hack_env :: ServerConf -> Environment -> IO Hack.Env
hyena_env_to_hack_env conf e = do
  i <- (L.fromChunks <$> (e.Wai.input .enumToList))
  return def
    {   
       Hack.requestMethod = convertRequestMethod (e.requestMethod)
    ,  Hack.scriptName    = e.scriptName.C.unpack
    ,  Hack.pathInfo      = e.pathInfo.C.unpack
    ,  Hack.queryString   = e.queryString .fromMaybe C.empty .C.unpack
    ,  Hack.http          = e.Wai.headers .map unpack_tuple
    ,  Hack.hackErrors    = e.errors
    ,  Hack.serverPort    = conf.port
    ,  Hack.serverName    = conf.serverName
    ,  Hack.hackInput     = i
    }
  where
    convertRequestMethod Wai.Options     =     Hack.OPTIONS
    convertRequestMethod Wai.Get         =     Hack.GET
    convertRequestMethod Wai.Head        =     Hack.HEAD
    convertRequestMethod Wai.Post        =     Hack.POST
    convertRequestMethod Wai.Put         =     Hack.PUT
    convertRequestMethod Wai.Delete      =     Hack.DELETE
    convertRequestMethod Wai.Trace       =     Hack.TRACE
    convertRequestMethod Wai.Connect     =     Hack.CONNECT

-- GHC 6.10 fails to accept this signature :(
--   enumToList :: Enumerator -> IO [S.ByteString]
enumToList :: ((() -> S.ByteString -> IO (Either () ())) -> () -> IO ())
           -> IO [S.ByteString]
enumToList enum =
  do ch <- newChan
     forkIO $ enum (writer ch) () >> writeChan ch Nothing
     xs <- getChanContents ch
     return $ map fromJust $ takeWhile isJust xs
  where writer ch () chunk = do writeChan ch (Just chunk)
                                return (Right ())

listToEnum :: [S.ByteString] -> Enumerator
listToEnum []     _ z = return z
listToEnum (x:xs) f z = f z x >>= either return (listToEnum xs f)

type WaiResponse = (Int, S.ByteString, Wai.Headers, Enumerator)

hack_response_to_hyena_response :: Enumerator -> Hack.Response -> WaiResponse
hack_response_to_hyena_response e r =
    (   r.Hack.status
    ,   r.Hack.status.show_status_message.fromMaybe "OK" .C.pack
    ,   r.Hack.headers.map pack_tuple
    ,   e
    )


hack_to_wai_with_config :: ServerConf -> Hack.Application -> Wai.Application
hack_to_wai_with_config conf app env = do
  hack_env <- env.hyena_env_to_hack_env conf
  
  r <- app hack_env
  
  let enum           = r.Hack.body.L.toChunks.listToEnum
      hyena_response = r.hack_response_to_hyena_response enum
  
  return hyena_response

run :: Hack.Application -> IO ()
run app = runWithConfig def app

runWithConfig :: ServerConf -> Hack.Application -> IO ()
runWithConfig conf app = do
  hyena_config <- Hyena.Config.configFromFlags
  let hyena_config_with_port =
          hyena_config { Hyena.Config.port = port conf
                       }
  app.hack_to_wai_with_config conf .(serveWithConfig hyena_config_with_port)


show_status_message :: Int -> Maybe String
show_status_message x = status_code.M.lookup x


status_code :: M.Map Int String
status_code =
  [  x       100          "Continue"
  ,  x       101          "Switching Protocols"
  ,  x       200          "OK"
  ,  x       201          "Created"
  ,  x       202          "Accepted"
  ,  x       203          "Non-Authoritative Information"
  ,  x       204          "No Content"
  ,  x       205          "Reset Content"
  ,  x       206          "Partial Content"
  ,  x       300          "Multiple Choices"
  ,  x       301          "Moved Permanently"
  ,  x       302          "Found"
  ,  x       303          "See Other"
  ,  x       304          "Not Modified"
  ,  x       305          "Use Proxy"
  ,  x       307          "Temporary Redirect"
  ,  x       400          "Bad Request"
  ,  x       401          "Unauthorized"
  ,  x       402          "Payment Required"
  ,  x       403          "Forbidden"
  ,  x       404          "Not Found"
  ,  x       405          "Method Not Allowed"
  ,  x       406          "Not Acceptable"
  ,  x       407          "Proxy Authentication Required"
  ,  x       408          "Request Timeout"
  ,  x       409          "Conflict"
  ,  x       410          "Gone"
  ,  x       411          "Length Required"
  ,  x       412          "Precondition Failed"
  ,  x       413          "Request Entity Too Large"
  ,  x       414          "Request-URI Too Large"
  ,  x       415          "Unsupported Media Type"
  ,  x       416          "Requested Range Not Satisfiable"
  ,  x       417          "Expectation Failed"
  ,  x       500          "Internal Server Error"
  ,  x       501          "Not Implemented"
  ,  x       502          "Bad Gateway"
  ,  x       503          "Service Unavailable"
  ,  x       504          "Gateway Timeout"
  ,  x       505          "HTTP Version Not Supported"
  ] .M.fromList
  where x a b = (a, b)