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