module Hack.Frontend.Happstack where
import Data.Foldable (toList)
import Data.Maybe
import Hack (http, pathInfo, scriptName, queryString, hackInput, serverName, serverPort, Application)
import Happstack.Server
import Happstack.Server.HTTP.Types (Request (..), Version (Version))
import Happstack.Server.SURI (parse)
import Network.URI (unEscapeString)
import qualified Data.ByteString.Char8 as S
import qualified Hack
import qualified Hack as Hack
import qualified Happstack.Server as H
serverPartToApp :: (ToMessage b) => ServerPartT IO b -> Application
serverPartToApp = convert . processRequest
convert :: (Request -> IO Response) -> Application
convert f = \env -> do
let rq = toHappstackRequest env
rs <- f rq
let r = toHackResponse rs
return r
toHackResponse :: Response -> Hack.Response
toHackResponse r = Hack.Response
{
Hack.body = rsBody r
, Hack.status = rsCode r
, Hack.headers = map convertHeader $ toList (rsHeaders r)
}
convertHeader :: HeaderPair -> (String, String)
convertHeader (HeaderPair k v) = (S.unpack k, S.unpack (last v))
toHappstackRequest :: Hack.Env -> Request
toHappstackRequest env =
tmpRequest
{ rqInputs = queryInput uri ++ bodyInput tmpRequest }
where
uri = fromJust $ parse $ concat $ map (\f -> f env)
[ serverName
, const ":"
, show . serverPort
, scriptName
, pathInfo
, add_q . queryString
]
tmpRequest =
Request { rqMethod = convertRequestMethod $ Hack.requestMethod env
, rqPaths = split '/' $ unescape $ pathInfo env
, rqUri = unescape $ scriptName env ++ pathInfo env
, rqQuery = unescape $ add_q $ queryString env
, rqInputs = []
, rqCookies = readCookies $ http env
, rqVersion = Version 1 1
, rqHeaders = mkHeaders $ http env
, rqBody = Body $ hackInput env
, rqPeer = (serverName env, serverPort env)
}
unescape = unEscapeString
convertRequestMethod Hack.OPTIONS = OPTIONS
convertRequestMethod Hack.GET = GET
convertRequestMethod Hack.HEAD = HEAD
convertRequestMethod Hack.POST = POST
convertRequestMethod Hack.PUT = PUT
convertRequestMethod Hack.DELETE = DELETE
convertRequestMethod Hack.TRACE = TRACE
convertRequestMethod Hack.CONNECT = CONNECT
readCookies = map cookieWithName
. either (const []) id . parseCookies . fromMaybe "" . lookup "Cookie"
add_q [] = []
add_q x = '?' : x
cookieWithName :: H.Cookie -> (String, H.Cookie)
cookieWithName x = (H.cookieName x, x)
processRequest :: (ToMessage b, Monad m, Functor m) => ServerPartT m b -> Request -> m Response
processRequest hs req = (runWebT $ runServerPartT hs req) >>= (return . (maybe standardNotFound id))
where
standardNotFound = H.setHeader "Content-Type" "text/html" $ toResponse "Not found"
split :: Char -> String -> [String]
split c cs = filter (not.null) $ worker [] cs
where worker acc [] = [reverse acc]
worker acc (c':cs') | c==c' = reverse acc:worker [] cs'
worker acc (c':cs') = worker (c':acc) cs'