-- 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 Control.Arrow ((>>>))
import Control.Monad.State
import Data.Char
import Data.Default
import Data.Default
import Data.List
import Data.Maybe
import Hack hiding (serverName)
import Happstack.Server.SimpleHTTP as Happstack hiding (port, escape)
import Network.URI (escapeURIString, isAllowedInURI)
import qualified Data.ByteString.Char8 as S
import qualified Data.Map as M
import qualified Hack as Hack
import qualified Happstack.Server.SimpleHTTP as H


-- | 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      = escape $ "/" ++ (intercalate "/" $ rqPaths req)
          , queryString   = escape $ 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 (== '?')
    
    escape = escapeURIString isAllowedInURI
    
    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"
  ]