-- code structure is written by John MacFarlane, 
-- I filled in some missing pieces and make it compile.

{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}

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

import qualified Hack as Hack
import Hack hiding (serverName)
import Happstack.Server.SimpleHTTP as Happstack hiding (port)
import qualified Happstack.Server.SimpleHTTP as H

import Control.Arrow ((>>>))
import Data.Default
import Data.List
import Data.Char
import Data.Maybe
import Control.Monad.State
import Data.Default

import qualified Data.Map as M
import qualified Data.ByteString.Char8 as S

-- | we need this for 1. port 2. a bug in current Happstack.
--   i.e. rqPeer will not give the corrent value for serverName and port
data ServerConf = ServerConf { port :: Int, serverName :: String }
instance Default ServerConf where
  def = ServerConf { port = 3000, serverName = "localhost" }

runWithConfig :: ServerConf -> Hack.Application -> IO ()
runWithConfig conf app =
 Happstack.simpleHTTP nullConf { H.port = port conf } $ myPart conf app

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

myPart :: ServerConf -> Hack.Application -> ServerPart (Happstack.Response)
myPart conf app = do
  req <- Happstack.askRq
  let env = reqToEnv conf req
  resp <- liftIO $ app env
  return $ toHappstackResponse resp

  where
    reqToEnv conf' req =
      def { requestMethod = convertRequestMethod $ rqMethod req
          , scriptName    = ""
          , pathInfo      = "/" ++ (intercalate "/" $ rqPaths req)
          , queryString   = remove_question_mark $ rqQuery req
          , Hack.serverName    = serverName conf' -- (fst $ rqPeer req) is supposed to work, but does not
          , serverPort    = port conf'
          , http           = toHttp (rqHeaders req)
          , hackInput     = (\(Body x) -> x) (rqBody req)
          }
    remove_question_mark = dropWhile (== '?')
    
    
    convertRequestMethod Happstack.OPTIONS     =     Hack.OPTIONS
    convertRequestMethod Happstack.GET         =     Hack.GET
    convertRequestMethod Happstack.HEAD        =     Hack.HEAD
    convertRequestMethod Happstack.POST        =     Hack.POST
    convertRequestMethod Happstack.PUT         =     Hack.PUT
    convertRequestMethod Happstack.DELETE      =     Hack.DELETE
    convertRequestMethod Happstack.TRACE       =     Hack.TRACE
    convertRequestMethod Happstack.CONNECT     =     Hack.CONNECT
          
          
          
toHttp :: Headers -> [(String, String)]
toHttp = M.toList >>> map snd >>> map headerToPair

headerToPair :: HeaderPair -> (String, String)
headerToPair (HeaderPair k v) = 
  (translate_header $ S.unpack k, intercalate " " $ map S.unpack v)

toHappstackResponse :: Hack.Response -> Happstack.Response
toHappstackResponse resp = Happstack.Response 
  {  rsCode      = Hack.status resp
  ,  rsHeaders   = convertHeaders $ Hack.headers resp
  ,  rsFlags     = RsFlags {rsfContentLength = False}
  ,  rsBody      = Hack.body resp
  ,  rsValidator = Nothing }


convertHeaders :: [(String, String)] -> Happstack.Headers
convertHeaders = map pairToHeader >>> M.fromList
  where 
    pairToHeader (k,v) = 
      ((S.pack $ map toLower k), HeaderPair (S.pack k) [S.pack v])


-- happstack converts all request header to lowercase ...
-- so we need to convert it back ...
translate_header :: String -> String
translate_header s = fromMaybe s $ find (map toLower >>> (== s) ) header_list

header_list :: [String]
header_list = 
  [    "Cache-Control"        
  ,    "Connection"           
  ,    "Date"                 
  ,    "Pragma"               
  ,    "Transfer-Encoding"    
  ,    "Upgrade"              
  ,    "Via"                  
  ,    "Accept"               
  ,    "Accept-Charset"       
  ,    "Accept-Encoding"      
  ,    "Accept-Language"      
  ,    "Authorization"        
  ,    "Cookie"               
  ,    "Expect"               
  ,    "From"                 
  ,    "Host"                 
  ,    "If-Modified-Since"    
  ,    "If-Match"             
  ,    "If-None-Match"        
  ,    "If-Range"             
  ,    "If-Unmodified-Since"  
  ,    "Max-Forwards"         
  ,    "Proxy-Authorization"  
  ,    "Range"                
  ,    "Referer"              
  ,    "User-Agent"           
  ,    "Age"                  
  ,    "Location"             
  ,    "Proxy-Authenticate"   
  ,    "Public"               
  ,    "Retry-After"          
  ,    "Server"               
  ,    "Set-Cookie"           
  ,    "TE"                   
  ,    "Trailer"              
  ,    "Vary"                 
  ,    "Warning"              
  ,    "WWW-Authenticate"     
  ,    "Allow"                
  ,    "Content-Base"         
  ,    "Content-Encoding"     
  ,    "Content-Language"     
  ,    "Content-Length"       
  ,    "Content-Location"     
  ,    "Content-MD5"          
  ,    "Content-Range"        
  ,    "Content-Type"         
  ,    "ETag"                 
  ,    "Expires"              
  ,    "Last-Modified"        
  ,    "Content-Transfer-Encodeing"
  ]