module Routes.Routes
(
parseRoutes
, parseRoutesFile
, parseRoutesNoCheck
, parseRoutesFileNoCheck
, mkRoute
, mkRouteSub
, routeDispatch
, customRouteDispatch
, showRoute
, showRouteQuery
, readRoute
, Handler
, HandlerS
, ResponseHandler
, Routable(..)
, RenderRoute(..)
, ParseRoute(..)
, RouteAttrs(..)
, Env(..)
, RequestData
, waiReq
, nextApp
, currentRoute
, runNext
, runHandler
, readQueryString
)
where
import Network.Wai (ResponseReceived, Middleware, Application, pathInfo, requestMethod, requestMethod, Response, Request(..))
import Network.HTTP.Types (Query, decodePath, encodePath, queryTextToQuery, queryToQueryText)
import Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..))
import Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType)
import 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 sub = forall master. RenderRoute master => HandlerS sub 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
]
instanceD :: Cxt -> Type -> [Dec] -> Dec
#if MIN_VERSION_template_haskell(2,11,0)
instanceD = InstanceD Nothing
#else
instanceD = InstanceD
#endif
mkRouteDispatch :: String -> [ResourceTree String] -> Q [Dec]
mkRouteDispatch typName routes = do
let typ = parseType typName
disp <- mkRouteDispatchClause routes
return [instanceD []
(ConT ''Routable `AppT` typ `AppT` typ)
[FunD (mkName "dispatcher") [disp]]]
mkRouteSubDispatch :: String -> String -> [ResourceTree a] -> Q [Dec]
mkRouteSubDispatch typName constraint routes = do
let typ = parseType typName
disp <- mkRouteDispatchClause routes
master <- newName "master"
className <- lookupTypeName constraint
let contract = maybe (error $ "Unknown typeclass " ++ show constraint) (getContract master) className
return [instanceD [contract]
(ConT ''Routable `AppT` typ `AppT` VarT master)
[FunD (mkName "dispatcher") [disp]]]
where
getContract master className =
#if MIN_VERSION_template_haskell(2,10,0)
ConT className `AppT` VarT master
#else
ClassP className [VarT master]
#endif
mkRouteDispatchClause :: [ResourceTree a] -> Q Clause
mkRouteDispatchClause =
mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [| runHandler |]
, mdsSubDispatcher = [| subDispatcher |]
, mdsGetPathInfo = [| getPathInfo |]
, mdsMethod = [| getReqMethod |]
, mdsSetPathInfo = [| setPathInfo |]
, mds404 = [| app404 |]
, mds405 = [| app405 |]
, mdsGetHandler = defaultGetHandler
, mdsUnwrapper = return
}
mkRoute :: String -> [ResourceTree String] -> Q [Dec]
mkRoute typName routes = do
dat <- mkRouteData typName routes
disp <- mkRouteDispatch typName routes
return (disp++dat)
mkRouteSub :: String -> String -> [ResourceTree String] -> Q [Dec]
mkRouteSub typName constraint routes = do
dat <- mkRouteData typName routes
disp <- mkRouteSubDispatch typName constraint routes
return (disp++dat)
class Routable sub master where
dispatcher :: HandlerS sub master
routeDispatch :: Routable master master => master -> Middleware
routeDispatch = customRouteDispatch dispatcher
customRouteDispatch :: HandlerS master master -> master -> Middleware
customRouteDispatch customDispatcher master def req = customDispatcher (_masterToEnv master) RequestData{waiReq=req, nextApp=def, currentRoute=Nothing}
showRouteQuery :: RenderRoute master => Route master -> [(Text,Text)] -> Text
showRouteQuery r q = uncurry _encodePathInfo $ second (map (second Just) . (++ q)) $ renderRoute r
showRoute :: RenderRoute master => Route master -> Text
showRoute = uncurry _encodePathInfo . second (map $ second Just) . renderRoute
_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 readQueryString . decodePath . encodeUtf8
readQueryString :: Query -> [(Text, Text)]
readQueryString = map (second (fromMaybe "")) . queryToQueryText
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}
_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