{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}

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

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

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

import qualified Data.Map as M
import qualified Data.ByteString.Lazy.Char8 as C
import qualified Data.ByteString as L
import qualified Data.ByteString.Internal as I

-- | 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 }

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

run :: Hack.Application -> IO ()
run = runWithConfig $ ServerConf { port = 3000, serverName = "localhost" }

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 { request_method = convertRequestMethod $ rqMethod req
          , script_name = ""
          , path_info = "/" ++ (intercalate "/" $ rqPaths req)
          , query_string = remove_question_mark $ rqQuery req
          , server_name = serverName conf' -- (fst $ rqPeer req) is supposed to work, but does not
          , server_port = port conf'
          , http = toHttp (rqHeaders req)
          , hack_input = (\(Body x) -> C.unpack 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 -> Hack.Map
toHttp = M.toList >>> map snd >>> map headerToPair

headerToPair :: HeaderPair -> (String, String)
headerToPair (HeaderPair k v) = (translate_header $ b2s k, intercalate " " $ map b2s v)
  where b2s x = map I.w2c $ L.unpack x

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


convertHeaders :: Hack.Map -> Happstack.Headers
convertHeaders = map pairToHeader >>> M.fromList
  where 
    pairToHeader (k,v) = ((c2b $ map toLower k), HeaderPair (c2b k) [c2b v])
    c2b x = L.pack $ map I.c2w x
  

-- 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"
  ]