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
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'
, 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])
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"
]