module Network.Wai.Middleware.Routes.Routes
(
parseRoutes
, parseRoutesFile
, parseRoutesNoCheck
, parseRoutesFileNoCheck
, mkRoute
, mkRouteData
, mkRouteDispatch
, mkRouteSubDispatch
, routeDispatch
, showRoute
, readRoute
, Handler
, HandlerS
, ResponseHandler
, Routable(..)
, RenderRoute(..)
, ParseRoute(..)
, RouteAttrs(..)
, Env(..)
, RequestData
, waiReq
, nextApp
, currentRoute
, runNext
)
where
import Network.Wai (ResponseReceived, Middleware, Application, pathInfo, requestMethod, requestMethod, Response, Request(..))
import Network.HTTP.Types (decodePath, encodePath, queryTextToQuery, queryToQueryText)
import Network.Wai.Middleware.Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..))
import Network.Wai.Middleware.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType)
import Network.Wai.Middleware.Routes.TH (mkRenderRouteInstance, mkParseRouteInstance, mkRouteAttrsInstance, mkDispatchClause, ResourceTree(..), MkDispatchSettings(..), defaultGetHandler)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Blaze.ByteString.Builder (toByteString)
import Language.Haskell.TH.Syntax
import Control.Arrow (second)
import Data.Maybe (fromMaybe)
data RequestData master = RequestData
{ waiReq :: Request
, nextApp :: Application
, currentRoute :: Maybe (Route master)
}
type ResponseHandler = (Response -> IO ResponseReceived) -> IO ResponseReceived
type App master = RequestData master -> ResponseHandler
data Env sub master = Env
{ envMaster :: master
, envSub :: sub
, envToMaster :: Route sub -> Route master
}
runNext :: App master
runNext req = nextApp req $ waiReq req
type Handler master = HandlerS master master
type HandlerS sub master = Env sub master -> App sub
mkRouteData :: String -> [ResourceTree String] -> Q [Dec]
mkRouteData typName routes = do
let typ = parseType typName
let rname = mkName $ "resources" ++ typName
let resourceTrees = map (fmap parseType) routes
eres <- lift routes
let resourcesDec =
[ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
, FunD rname [Clause [] (NormalB eres) []]
]
rinst <- mkRenderRouteInstance typ resourceTrees
pinst <- mkParseRouteInstance typ resourceTrees
ainst <- mkRouteAttrsInstance typ resourceTrees
return $ concat [ [ainst]
, [pinst]
, resourcesDec
, rinst
]
mkRouteSubDispatch :: [ResourceTree a] -> Q Exp
mkRouteSubDispatch routes = do
disp <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [| runHandler |]
, mdsSubDispatcher = [| subDispatcher |]
, mdsGetPathInfo = [| getPathInfo |]
, mdsMethod = [| getReqMethod |]
, mdsSetPathInfo = [| setPathInfo |]
, mds404 = [| app404 |]
, mds405 = [| app405 |]
, mdsGetHandler = defaultGetHandler
} routes
inner <- newName "inner"
let innerFun = FunD inner [disp]
helper <- newName "helper"
let fun = FunD helper
[ Clause
[]
(NormalB $ VarE inner)
[innerFun]
]
return $ LetE [fun] (VarE helper)
mkRouteDispatch :: String -> [ResourceTree String] -> Q [Dec]
mkRouteDispatch typName routes = do
let typ = parseType typName
disp <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [| runHandler |]
, mdsSubDispatcher = [| subDispatcher |]
, mdsGetPathInfo = [| getPathInfo |]
, mdsMethod = [| getReqMethod |]
, mdsSetPathInfo = [| setPathInfo |]
, mds404 = [| app404 |]
, mds405 = [| app405 |]
, mdsGetHandler = defaultGetHandler
} routes
return [InstanceD []
(ConT ''Routable `AppT` typ `AppT` typ)
[FunD (mkName "dispatcher") [disp]]]
mkRoute :: String -> [ResourceTree String] -> Q [Dec]
mkRoute typName routes = do
dat <- mkRouteData typName routes
disp <- mkRouteDispatch typName routes
return (disp++dat)
class Routable sub master where
dispatcher :: HandlerS sub master
routeDispatch :: Routable master master => master -> Middleware
routeDispatch master def req = dispatcher (_masterToEnv master) RequestData{waiReq=req, nextApp=def, currentRoute=Nothing}
showRoute :: RenderRoute master => Route master -> Text
showRoute = uncurry encodePathInfo . second (map $ second Just) . renderRoute
where
encodePathInfo :: [Text] -> [(Text, Maybe Text)] -> Text
encodePathInfo [] = encodePathInfo [""]
encodePathInfo segments = decodeUtf8 . toByteString . encodePath segments . queryTextToQuery
readRoute :: ParseRoute master => Text -> Maybe (Route master)
readRoute = parseRoute . second (map (second (fromMaybe "")) . queryToQueryText) . decodePath . encodeUtf8
getReqMethod :: RequestData master -> ByteString
getReqMethod = requestMethod . waiReq
getPathInfo :: RequestData master -> [Text]
getPathInfo = pathInfo . waiReq
setPathInfo :: [Text] -> RequestData master -> RequestData master
setPathInfo p reqData = reqData { waiReq = (waiReq reqData){pathInfo=p} }
app404 :: HandlerS sub master
app404 _master = runNext
app405 :: HandlerS sub master
app405 _master = runNext
runHandler
:: HandlerS sub master
-> Env sub master
-> Maybe (Route sub)
-> App sub
runHandler h env route reqdata = h env reqdata{currentRoute=route}
subDispatcher
:: Routable sub master
=> (HandlerS sub master -> Env sub master -> Maybe (Route sub) -> App sub)
-> (master -> sub)
-> (Route sub -> Route master)
-> Env master master
-> App master
subDispatcher _runhandler getSub toMasterRoute env reqData = dispatcher env' reqData'
where
env' = _envToSub getSub toMasterRoute env
reqData' = reqData{currentRoute=Nothing}
qq (k,mv) = (decodeUtf8 k, maybe "" decodeUtf8 mv)
req = waiReq reqData
_masterToEnv :: master -> Env master master
_masterToEnv master = Env master master id
_envToSub :: (master -> sub) -> (Route sub -> Route master) -> Env master master -> Env sub master
_envToSub getSub toMasterRoute env = Env master sub toMasterRoute
where
master = envMaster env
sub = getSub master