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