module Hack2.Handler.HappstackServer (run, runWithConfig, ServerConf(..), appToServerPart) where
import Control.Arrow ((>>>))
import "mtl" Control.Monad.State
import Data.Char
import Data.Default
import Data.List
import Data.Maybe
import qualified Hack2 as Hack2
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.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import qualified Happstack.Server.SimpleHTTP as H
import qualified Data.ByteString.Char8 as Strict
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Enumerator.Binary as EB
import qualified Data.Enumerator.List as EL
import Data.Enumerator (run_, enumList, Enumerator, ($$))
fromEnumerator :: Monad m => Enumerator Strict.ByteString m B.ByteString -> m B.ByteString
fromEnumerator m = run_ $ m $$ EB.consume
toEnumerator :: Monad m => B.ByteString -> Enumerator Strict.ByteString m a
toEnumerator = enumList 1 . B.toChunks
data ServerConf = ServerConf { port :: Int, serverName :: L.ByteString }
deriving (Show)
instance Default ServerConf where
def = ServerConf { port = 3000, serverName = "localhost"}
runWithConfig :: ServerConf -> Hack2.Application -> IO ()
runWithConfig conf = simpleHTTP nullConf { H.port = port conf } . appToServerPart conf
run :: Hack2.Application -> IO ()
run = runWithConfig def
appToServerPart :: ServerConf -> Hack2.Application -> ServerPart (Happstack.Response)
appToServerPart conf app = askRq >>= \req -> liftIO $ (app $ reqToEnv req) >>= hackRToServerPartR
where
reqToEnv req =
def
{ Hack2.requestMethod = convertRequestMethod $ rqMethod req
, Hack2.scriptName = S.empty
, Hack2.pathInfo = S.pack $ escape $ "/" ++ (intercalate "/" $ rqPaths req)
, Hack2.queryString = S.pack $ escape $ dropWhile (== '?') $ rqQuery req
, Hack2.serverName = l2s $ serverName conf
, Hack2.serverPort = (snd $ rqPeer req)
, Hack2.httpHeaders = headersToHttp (rqHeaders req)
, Hack2.hackInput = Hack2.HackEnumerator $ toEnumerator $ (\(Body x) -> x) (rqBody req)
, Hack2.hackHeaders = [("RemoteHost", S.pack $ fst $ rqPeer req)]
}
escape = escapeURIString isAllowedInURI
convertRequestMethod Happstack.OPTIONS = Hack2.OPTIONS
convertRequestMethod Happstack.GET = Hack2.GET
convertRequestMethod Happstack.HEAD = Hack2.HEAD
convertRequestMethod Happstack.POST = Hack2.POST
convertRequestMethod Happstack.PUT = Hack2.PUT
convertRequestMethod Happstack.DELETE = Hack2.DELETE
convertRequestMethod Happstack.TRACE = Hack2.TRACE
convertRequestMethod Happstack.CONNECT = Hack2.CONNECT
headersToHttp :: Headers -> [(S.ByteString, S.ByteString)]
headersToHttp = M.toList >>> map snd >>> map headerToPair
where
headerToPair (HeaderPair k v) =
(S.pack $ normalizeHeader $ S.unpack k, S.intercalate " " v)
hackRToServerPartR :: Hack2.Response -> IO Happstack.Response
hackRToServerPartR r = do
body_bytestring <- fromEnumerator $ Hack2.unHackEnumerator $ Hack2.body r
return $
Happstack.Response
{ rsCode = Hack2.status r
, rsHeaders = httpToHeaders $ Hack2.headers r
, rsFlags = RsFlags {rsfContentLength = False}
, rsBody = body_bytestring
, rsValidator = Nothing
}
l2s :: L.ByteString -> S.ByteString
l2s = S.concat . L.toChunks
s2l :: S.ByteString -> L.ByteString
s2l = L.fromChunks . return
httpToHeaders :: [(S.ByteString, S.ByteString)] -> Headers
httpToHeaders = map pairToHeader >>> M.fromList
where
pairToHeader (k,v) =
((S.pack $ map toLower $ S.unpack k), HeaderPair (k) [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"
]