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)
data RequestData = RequestData
{ waiReq :: Request
, nextApp :: Application
}
runNext :: RequestData -> ResourceT IO Response
runNext req = nextApp req $ waiReq req
type App = RequestData -> ResourceT IO Response
type Handler master = master -> App
app404 :: Handler master
app404 _master req = nextApp req $ waiReq req
app405 :: Handler master
app405 _master _req = return $ ResponseBuilder status405 [("Content-Type","text/plain")] $ 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)
-> App
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