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

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


import Control.Arrow ((>>>))
import Control.Monad.State
import Data.Char
import Data.Default
import Data.List
import Data.Maybe
import Hack hiding (serverName)
import qualified Hack as Hack
import Happstack.Server.SimpleHTTP as Happstack hiding (port, escape)
import Network.URI (escapeURIString, isAllowedInURI)
import Control.Applicative

import qualified Data.ByteString.Char8 as S
import qualified Data.Map as M
import qualified Happstack.Server.SimpleHTTP as H


data ServerConf = ServerConf { port :: Int, serverName :: String }
  deriving (Show)

instance Default ServerConf where
  def = ServerConf { port = 3000, serverName = "localhost"}

runWithConfig :: ServerConf -> Application -> IO ()
runWithConfig conf = simpleHTTP nullConf { H.port = port conf } . appToServerPart conf

run :: Application -> IO ()
run = runWithConfig def

appToServerPart :: ServerConf -> Application -> ServerPart (Happstack.Response)
appToServerPart conf app = askRq >>= liftIO . (hackRToServerPartR <$>) . app . reqToEnv
  where
    reqToEnv req =
      def
        { requestMethod   = convertRequestMethod $ rqMethod req
        , scriptName      = ""
        , pathInfo        = escape $ "/" ++ (intercalate "/" $ rqPaths req)
        , queryString     = escape $ dropWhile (== '?') $ rqQuery req
        , Hack.serverName = serverName conf
        , serverPort      = (snd $ rqPeer req)
        , http            = headersToHttp (rqHeaders req)
        , hackInput       = (\(Body x) -> x) (rqBody req)
        , remoteHost      = (fst $ rqPeer req) 
        }
    
    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
    

headersToHttp :: Headers -> [(String, String)]
headersToHttp = M.toList >>> map snd >>> map headerToPair
  where
    headerToPair (HeaderPair k v) = 
      (normalizeHeader $ S.unpack k, intercalate " " $ map S.unpack v)

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

httpToHeaders :: [(String, String)] -> Headers
httpToHeaders = 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 ...
normalizeHeader :: String -> String
normalizeHeader s = fromMaybe s $ find (map toLower >>> (== s) ) headerList

headerList :: [String]
headerList = 
  [ "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"
  ]