module Network.Wai.Middleware.Routes.Routes
(
parseRoutes
, parseRoutesFile
, parseRoutesNoCheck
, parseRoutesFileNoCheck
, mkRoute
, routeDispatch
, showRoute
, readRoute
, Handler
, Routable(..)
, RenderRoute(..)
, ParseRoute(..)
, RouteAttrs(..)
, RequestData
, waiReq
, nextApp
, runNext
)
where
import Data.Conduit (ResourceT)
import Network.Wai (Middleware, Application, pathInfo, requestMethod, requestMethod, Response(ResponseBuilder), Request(..))
import Network.HTTP.Types (decodePath, encodePath, queryTextToQuery, queryToQueryText, status405)
import Yesod.Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..))
import Yesod.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType)
import Yesod.Routes.TH (mkRenderRouteInstance, mkParseRouteInstance, mkRouteAttrsInstance, mkDispatchClause, ResourceTree(..), MkDispatchSettings(..), defaultGetHandler)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Blaze.ByteString.Builder (toByteString, fromByteString)
import Language.Haskell.TH.Syntax
import Control.Arrow (second)
import Data.Maybe (fromMaybe)
import Network.Wai.Middleware.Routes.ContentTypes
data RequestData = RequestData
{ waiReq :: Request
, nextApp :: Application
}
runNext :: RequestData -> ResourceT IO Response
runNext req = nextApp req $ waiReq req
type Handler master = master -> RequestData -> ResourceT IO Response
app404 :: Handler master
app404 _master req = nextApp req $ waiReq req
app405 :: Handler master
app405 _master _req = return $ ResponseBuilder status405 [contentType typePlain] $ fromByteString "405 - Method Not Allowed"
mkRoute :: String -> [ResourceTree String] -> Q [Dec]
mkRoute typName routes = do
let typ = parseType typName
let resourceTrees = map (fmap parseType) routes
rinst <- mkRenderRouteInstance typ resourceTrees
pinst <- mkParseRouteInstance typ resourceTrees
ainst <- mkRouteAttrsInstance typ resourceTrees
disp <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [| runHandler |]
, mdsSubDispatcher = [| undefined |]
, mdsGetPathInfo = [| pathInfo . waiReq |]
, mdsMethod = [| requestMethod . waiReq |]
, mdsSetPathInfo = [| undefined |]
, mds404 = [| app404 |]
, mds405 = [| app405 |]
, mdsGetHandler = defaultGetHandler
} routes
return $ InstanceD []
(ConT ''Routable `AppT` typ)
[FunD (mkName "dispatcher") [disp]]
: ainst
: pinst
: rinst
runHandler
:: Handler master
-> master
-> Maybe (Route master)
-> RequestData -> ResourceT IO Response
runHandler h master _ = h master
class Routable master where
dispatcher :: Handler master
routeDispatch :: Routable master => master -> Middleware
routeDispatch master def req = dispatcher master RequestData{waiReq=req, nextApp=def}
showRoute :: RenderRoute master => Route master -> Text
showRoute = uncurry encodePathInfo . second (map $ second Just) . renderRoute
where
encodePathInfo :: [Text] -> [(Text, Maybe Text)] -> Text
encodePathInfo segments = decodeUtf8 . toByteString . encodePath segments . queryTextToQuery
readRoute :: ParseRoute master => Text -> Maybe (Route master)
readRoute = parseRoute . second (map (second (fromMaybe "")) . queryToQueryText) . decodePath . encodeUtf8