diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # ChangeLog for yesod-core +## 1.7.0.0 + +* Split route compilation ([#1887](https://github.com/yesodweb/yesod/pull/1887), [guide](https://github.com/yesodweb/yesod/blob/master/yesod-core/docs/split-route-compilation.md)): + * Use `setFocusOnNestedRoute` to generate a nested route block's types and dispatch in their own module — for top-level sites, subsites, and parameterized foundations (`data App a`). + * `setNestedRouteFallthrough` lets a nested parent with no matching child fall through to later sibling routes instead of committing to a 404. + * Nested route fragments work in `redirect`/`setUrl`: wrap them in `WithParentArgs`, or use the bare constructor when the parent binds no dynamic pieces. + * `mkNestedSubDispatchInstance` (for hand-written split subsite modules) takes resources as `[ResourceTree String]` — the `parseRoutes` quasi-quoter's output — and parses the type strings internally. No `map (fmap (parseType . dropBracket))` step, and a malformed type fails the splice with an attributable error. + * Clearer TH errors for malformed route blocks, subsite/nested-datatype arity mismatches, and missing focus targets. + * Breaking: modules that splice a nested route block need `MultiParamTypeClasses` (and usually `FlexibleContexts`). + * Breaking: TH codegen entry points changed (`TyArgs` threading; `mkDispatchClause`, `mkParseRouteInstance`, `mkRouteConsOpts`, `mkDispatchInstance`); `mkRenderRouteClauses` and the `MkRouteOpts` constructor are no longer exported. +* `ResourceParent` records the parent's own route attributes; `frParentDetails` replaces `frParentPieces`. [#1911](https://github.com/yesodweb/yesod/pull/1911) + ## 1.6.29.1 * Fix compilation error for text >= 2.1.2 [#1905](https://github.com/yesodweb/yesod/pull/1905) diff --git a/docs/split-route-compilation.md b/docs/split-route-compilation.md new file mode 100644 --- /dev/null +++ b/docs/split-route-compilation.md @@ -0,0 +1,256 @@ +# Split route compilation + +As of yesod-core 1.7, route definitions can be split across multiple modules. +A nested route block gets its own datatype, instances, and dispatch generated +in its own module, and the main `mkYesod` splice *delegates* to that module +instead of regenerating everything in one place. + +Why you'd want this: + +* **Smaller TH splices.** A large site no longer needs one giant `mkYesod` + splice that regenerates everything whenever any route changes. +* **Parallel compilation.** Each fragment module compiles independently. +* **Locality.** A route group's handlers, datatype, and dispatch live in one + module, next to each other. +* **Faster test feedback.** Each fragment gets its own `YesodDispatchNested` + instance, which is enough to dispatch a request on its own. + [hspec-yesod](https://github.com/parsonsmatt/hspec-yesod) is building on + this to run specs against a single route fragment, so a spec depends only on + the handlers it actually exercises — editing an unrelated handler no longer + recompiles (or relinks) the test module. + +## How it works + +Any nested route block — a parent declared with a trailing `:` — gets its own +route datatype: + +``` +/nest NestR: + / NestIndexR GET POST + /#Int NestShowR GET POST +``` + +By default, `mkYesod` generates the `NestR` datatype and its dispatch inline, +exactly as in 1.6. But if a `YesodDispatchNested NestR` instance is already in +scope at the splice site (because a separately compiled module generated it), +`mkYesod` delegates to that instance instead. Single-module sites are +unchanged; splitting is opt-in and per-parent. + +## Recipe: top-level site + +Three modules: a shared route table, the split-out fragment, and the main site. + +First, put the route definitions in their own module so both sides can see +them — along with your project's `RouteOpts`. Every splice that touches the +route table should use the same options, so define them once (see +[Fallthrough](#fallthrough) for why fallthrough should be on): + +```haskell +module App.Routes.Resources where + +import Yesod.Core + +appRouteOpts :: RouteOpts +appRouteOpts = setNestedRouteFallthrough True defaultOpts + +appRouteOptsFor :: String -> RouteOpts +appRouteOptsFor name = setFocusOnNestedRoute name appRouteOpts + +appResources :: [ResourceTree String] +appResources = [parseRoutes| + / HomeR GET + + /nest NestR: + / NestIndexR GET POST + /#Int NestShowR GET POST +|] +``` + +Then generate the `NestR` fragment in its own module by focusing the splice +on it. The fragment's handlers live here too: + +```haskell +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module App.Routes.NestR where + +import Yesod.Core +import Data.Text (Text) +import App.Routes.Resources + +mkYesodOpts (appRouteOptsFor "NestR") "App" appResources + +getNestIndexR :: HandlerFor App Text +getNestIndexR = pure "nest index" + +postNestIndexR :: HandlerFor App Text +postNestIndexR = pure "posted" + +getNestShowR :: Int -> HandlerFor App Text +getNestShowR _ = pure "nest show" + +postNestShowR :: Int -> HandlerFor App Text +postNestShowR _ = pure "posted" +``` + +Finally, the main module imports the fragment and splices with the same +options: + +```haskell +module App where + +import Yesod.Core +import App.Routes.Resources +import App.Routes.NestR (NestR (..)) + +mkYesodOpts appRouteOpts "App" appResources + +getHomeR :: HandlerFor App Text +getHomeR = pure "home" +``` + +Because `App.Routes.NestR` compiled first, the `mkYesodOpts` splice sees the +`YesodDispatchNested NestR` instance and delegates to it rather than +regenerating the `NestR` code. If you want to separate the datatype from the +dispatch further, `mkYesodDataOpts` and `mkYesodDispatchOpts` accept the same +options. + +## Recipe: subsites + +Subsites split the same way. The data module generates the subsite's route +datatype and nested-fragment instances: + +```haskell +module App.SplitSub.Data where + +import Yesod.Core + +data SplitSub = SplitSub + +mkYesodSubData "SplitSub" [parseRoutes| +/ SplitHomeR GET +/nested NestedR: + / NestedHomeR GET + /detail/#Int NestedDetailR GET +|] +``` + +The split-out module holds the nested handlers and generates the +`YesodSubDispatchNested` instance with `mkNestedSubDispatchInstance`: + +```haskell +{-# OPTIONS_GHC -Wno-orphans #-} + +module App.SplitSub.NestedR (NestedR (..)) where + +import Yesod.Core +import Yesod.Core.Dispatch + (mkNestedSubDispatchInstance, defaultOpts, TyArgs (..)) +import App.SplitSub.Data + +getNestedHomeR :: SubHandlerFor SplitSub master Text +getNestedHomeR = pure "nested home" + +getNestedDetailR :: Int -> SubHandlerFor SplitSub master Text +getNestedDetailR _ = pure "nested detail" + +$(mkNestedSubDispatchInstance + defaultOpts -- or your project-wide RouteOpts; see Fallthrough below + "NestedR" + [] -- no instance context + NoTyArgs -- no type arguments (non-parameterized subsite) + return -- handler unwrapper + resourcesSplitSub) -- the [ResourceTree String] from your routes file +``` + +`mkNestedSubDispatchInstance` takes the resources as `[ResourceTree String]` — +exactly what the `parseRoutes` quasi-quoter produces — and parses the type +strings internally, failing the splice with an attributable error on a +malformed type rather than a deferred runtime `error`. + +And the subsite's `YesodSubDispatch` instance delegates automatically, as long +as the split-out instance is in scope: + +```haskell +import App.SplitSub.Data +import App.SplitSub.NestedR () -- instance import only; no handlers leak + +instance YesodSubDispatch SplitSub master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesSplitSub) +``` + +For a subsite defined entirely in one module (including parameterized subsites +like `data MySub a`), `mkYesodSubDispatchInstance "(MyClass a) => MySub a" +resourcesMySub` generates the `YesodSubDispatch` and nested instances in one +splice. + +## Linking to nested routes + +A nested fragment constructor isn't a `Route App` on its own — its parent may +bind dynamic pieces the fragment doesn't carry. To use a fragment in +`redirect` or `setUrl`, wrap it in `WithParentArgs` together with the parent's +dynamic arguments: + +```haskell +redirect (WithParentArgs userId (ProfileEditR "name")) +``` + +When the parent binds no dynamic pieces, the bare constructor works directly — +generated `RedirectUrl`/`UrlToDispatch` instances fill in the empty parent +arguments: + +```haskell +redirect NestIndexR +``` + +For this reason, if you are splitting up your routes for compilation, it is +recommended to avoid captures in the parent prefix (prefer +`/admin AdminR:` over `/user/#UserId UserR:`). With a static-only prefix, +every fragment constructor is usable directly in `redirect`/`setUrl`, and +`WithParentArgs` never enters the picture. Dynamic pieces can still live on +the individual child routes. + +To convert a fragment into its parent's route type explicitly, use +`toParentRoute` from `Yesod.Core.Class.Dispatch.ToParentRoute` (not +re-exported from `Yesod.Core`, since the name is easy to collide with). + +## Fallthrough + +By default, once dispatch enters a nested parent whose subtree has no matching +child, the response is a 404 — later sibling routes are never tried. This +matters a lot when splitting: the usual first step is wrapping a batch of +previously-flat routes in a new nested group, and with fallthrough off, any +request matching the group's prefix now *commits* to that group. A route +declared later that shares the prefix silently becomes unreachable — flat +dispatch would have kept trying, the grouped version 404s. Enabling +`setNestedRouteFallthrough` restores the flat-dispatch behavior: a parent +whose subtree has no match falls through to the routes after it. + +Fallthrough is decided per splice: each module containing a parent route +decides for its own parents. Mixing modules spliced with different options +gives confusingly inconsistent dispatch, which is why the recipe above defines +`appRouteOpts`/`appRouteOptsFor` once and uses them everywhere — don't reach +for `defaultOpts` directly in individual modules. + +Related gotcha: a nested parent with *no* leading static path piece matches +unconditionally, so siblings declared after it are unreachable unless +fallthrough is enabled. Give the parent a static segment or enable +fallthrough. + +## Troubleshooting + +* **`Target 'NestR' was not found in resources.`** — the name passed to + `setFocusOnNestedRoute` doesn't match any nested parent in the route table. +* **Missing-extension errors** — fragment-generating modules need + `MultiParamTypeClasses`, and usually `FlexibleContexts` and + `FlexibleInstances`. GHC's error names the missing extension. +* **Duplicate `RedirectUrl` instance** — the generated convenience instance is + `OVERLAPPABLE`, so a *more specific* hand-written instance wins, but a + hand-written instance with the identical head is still a duplicate-instance + error. diff --git a/src/Yesod/Core.hs b/src/Yesod/Core.hs --- a/src/Yesod/Core.hs +++ b/src/Yesod/Core.hs @@ -8,10 +8,23 @@ ( -- * Type classes Yesod (..) , YesodDispatch (..) + , YesodDispatchNested (..) , YesodSubDispatch (..) + , YesodSubDispatchNested (..) , RenderRoute (..) + -- | Note: the 'toParentRoute' method is intentionally /not/ re-exported + -- here. It collides with a common local binding name (e.g. the + -- @toParentRoute@ from @getRouteToParent@), so an @import Yesod@ should not + -- inject it. Import it from "Yesod.Core.Class.Dispatch.ToParentRoute" when + -- you need it. + , ToParentRoute + , RenderRouteNested (..) , ParseRoute (..) , RouteAttrs (..) + -- | @since 1.7.0.0 + , ParseRouteNested (..) + -- | @since 1.7.0.0 + , RouteAttrsNested (..) -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs @@ -19,6 +32,10 @@ , Approot (..) , FileUpload (..) , ErrorResponse (..) + -- | The field accessors @theParentArgs@\/@parentArgsFor@ are not + -- re-exported (generic names that would shadow common local bindings); + -- only the type and its constructor are. + , WithParentArgs (WithParentArgs) -- * Utilities , maybeAuthorized , widgetToPageContent @@ -141,6 +158,7 @@ import Data.Version (showVersion) import Yesod.Routes.Class import UnliftIO (MonadIO (..), MonadUnliftIO (..)) +import Yesod.Core.Class.Dispatch.ToParentRoute import Control.Monad.Trans.Resource (MonadResource (..)) import Yesod.Core.Internal.LiteApp diff --git a/src/Yesod/Core/Class/Dispatch.hs b/src/Yesod/Core/Class/Dispatch.hs --- a/src/Yesod/Core/Class/Dispatch.hs +++ b/src/Yesod/Core/Class/Dispatch.hs @@ -1,26 +1,171 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} module Yesod.Core.Class.Dispatch where -import qualified Network.Wai as W -import Yesod.Core.Types -import Yesod.Core.Content (ToTypedContent (..)) -import Yesod.Core.Handler (sendWaiApplication) +import Data.ByteString.Builder (toLazyByteString, byteString) +import Data.Proxy (Proxy(..)) +import Data.Text (Text) +import Network.HTTP.Types (status301, status307) +import Yesod.Core.Class.Dispatch.ToParentRoute import Yesod.Core.Class.Yesod +import Yesod.Core.Content (ToTypedContent (..)) +import Yesod.Core.Handler (sendWaiApplication, RedirectUrl, notFound) +import Yesod.Core.Internal.Run +import Yesod.Core.Types +import Yesod.Routes.Class +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as BL +import qualified Network.Wai as W -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Yesod site => YesodDispatch site where yesodDispatch :: YesodRunnerEnv site -> W.Application +-- | This class enables you to dispatch on a route fragment without needing +-- to know how to dispatch on the entire route structure. This allows you +-- to break up route generation into multiple files. +-- +-- For details on use, see 'setFocusOnNestedRoute'. +-- +-- @since 1.7.0.0 +class RenderRouteNested a => YesodDispatchNested a where + -- | Dispatches a request to a nested route fragment. + -- + -- The implementation uses the full WAI 'Request' to determine if the + -- remaining path (after the parent route) matches any child routes. + -- Returns 'Nothing' if no child routes match (for fallthrough to other + -- routes), or 'Just' a continuation that handles the request. + -- + -- The parent depth (number of path pieces consumed by the parent route) + -- is statically known during Template Haskell generation and baked into + -- the generated instance. + -- + -- @since 1.7.0.0 + yesodDispatchNested + :: (Yesod (ParentSite a)) + => Proxy a + -- ^ Type proxy to resolve ambiguity from non-injective type families + -> ParentArgs a + -- ^ The dynamic arguments from the parent route + -> (a -> Route (ParentSite a)) + -- ^ Function to wrap the nested route in the parent constructor + -> YesodRunnerEnv (ParentSite a) + -- ^ The runner environment + -> W.Request + -- ^ The full WAI request + -> Maybe ((W.Response -> IO W.ResponseReceived) -> IO W.ResponseReceived) + -- ^ Returns 'Nothing' for fallthrough, or 'Just' a continuation + -- that completes the 'Application' type when given a respond callback + +-- | 'YesodDispatchNested' is a more flexible class than 'YesodDispatch', +-- and this instance is the proof. Given a @'Route' site@ we can dispatch +-- on it as normal, so this code path works. This allows us to create +-- generalized helpers and reuse them, ensuring that nested and top-level +-- dispatch remain equivalent. This instance therefore always returns +-- @'Just'@ — committing to 'yesodDispatch', which itself terminates in +-- a 404 on a miss — rather than the 'Nothing' that the class haddock +-- describes for /fragment/ instances. The only intended caller is the +-- terminal authority 'toWaiAppYreNested', where that 404 is exactly the +-- right answer; do not rely on this instance to signal fallthrough. +instance YesodDispatch site => YesodDispatchNested (Route site) where + yesodDispatchNested _ _ _ yre req = Just $ yesodDispatch yre req + +-- | Build a WAI 'W.Application' for @site@, indexed by a @url@ type that can +-- be rendered to a route of @site@ (via 'RedirectUrl'). +-- +-- Note that dispatch is purely path-based: the hand-written instances below +-- discard the @url@ value (@urlToDispatch _ = yesodDispatch@) and route on the +-- request's @pathInfo@. The @url@ argument exists only to select the instance +-- and to carry the 'RedirectUrl' constraint — it is not consulted at runtime. +-- +-- This is equivalent to 'YesodDispatch' but allows us to vary on the +-- @url@ type, which lets us demand additional constraints in test +-- contexts. +-- +-- @since 1.7.0.0 +class RedirectUrl site url => UrlToDispatch url site where + -- | @since 1.7.0.0 + urlToDispatch :: url -> YesodRunnerEnv site -> W.Application + +instance YesodDispatch site => UrlToDispatch (Route site) site where + urlToDispatch _ = yesodDispatch + +instance (YesodDispatch site, RedirectUrl site (Route site, a)) => UrlToDispatch (Route site, a) site where + urlToDispatch _ = yesodDispatch + +instance YesodDispatch site => UrlToDispatch Text site where + urlToDispatch _ = yesodDispatch + +instance YesodDispatch site => UrlToDispatch String site where + urlToDispatch _ = yesodDispatch + +-- | This instance is the pattern upon which 'UrlToDispatch' instances are +-- generated for subsite fragments. Given the constraints, we are able to +-- call 'toWaiAppYreNested' at the @route@ type with the correct arguments. +-- This allows us to create an application for a fragment of a site. +-- +-- @since 1.7.0.0 +instance + ( ParentSite route ~ site + , YesodDispatchNested route + , RedirectUrl site (WithParentArgs route) + , Yesod site + , ToParentRoute route + ) + => + UrlToDispatch (WithParentArgs route) site + where + urlToDispatch (WithParentArgs args _) = + toWaiAppYreNested (Proxy :: Proxy route) args + class YesodSubDispatch sub master where yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application +-- | Like 'YesodDispatchNested', but for subsites. This class enables +-- class-based delegation for nested routes within subsites, allowing +-- module separation and symmetry with 'YesodDispatchNested'. +-- +-- When a 'YesodSubDispatchNested' instance exists for a nested route type, +-- 'mkYesodSubDispatch' will delegate to it instead of inlining the dispatch. +-- Use 'mkYesodSubDispatchInstance' to generate both 'YesodSubDispatch' and +-- 'YesodSubDispatchNested' instances in one splice. +-- +-- @since 1.7.0.0 +class RenderRouteNested a => YesodSubDispatchNested a where + -- | Dispatches a request for a nested route fragment within a subsite. + -- + -- Similar to 'yesodDispatchNested', but works with 'YesodSubRunnerEnv' + -- instead of 'YesodRunnerEnv', making it suitable for subsites. + -- The @master@ type is universally quantified since it's not determined + -- by the nested route type. + -- + -- @since 1.7.0.0 + yesodSubDispatchNested + :: Proxy a + -- ^ Type proxy to resolve ambiguity from non-injective type families + -> ParentArgs a + -- ^ The dynamic arguments from the parent route + -> (a -> Route (ParentSite a)) + -- ^ Function to wrap the nested route in the parent constructor + -> YesodSubRunnerEnv (ParentSite a) master + -- ^ The subsite runner environment + -> W.Request + -- ^ The full WAI request + -> Maybe ((W.Response -> IO W.ResponseReceived) -> IO W.ResponseReceived) + -- ^ Returns 'Nothing' for fallthrough, or 'Just' a continuation + instance YesodSubDispatch WaiSubsite master where yesodSubDispatch YesodSubRunnerEnv {..} = app where @@ -51,3 +196,50 @@ , rheRouteToMaster = ysreToParentRoute } in f hd { handlerEnv = rhe' } + +-- | Build a WAI 'W.Application' that dispatches starting at a nested route +-- fragment @a@ (rather than the whole @'Route' site@), given a +-- 'YesodRunnerEnv' for the parent site and the parent route's 'ParentArgs'. +-- Handles @cleanPath@ redirects and a terminal 404 just like 'toWaiAppYre'. +-- +-- @since 1.7.0.0 +toWaiAppYreNested + :: (Yesod (ParentSite a), YesodDispatchNested a, ToParentRoute a) + => Proxy a + -> ParentArgs a + -> YesodRunnerEnv (ParentSite a) + -> W.Application +toWaiAppYreNested proxy parentArgs yre req = + case cleanPath site $ W.pathInfo req of + Left pieces -> sendRedirect site pieces req + Right pieces -> do + let mapplication = + yesodDispatchNested proxy parentArgs (toParentRoute parentArgs) yre req + { W.pathInfo = pieces + } + case mapplication of + Nothing -> + yesodRunner (notFound :: HandlerFor site ()) yre Nothing req + Just k -> + k + where + site = yreSite yre + sendRedirect :: Yesod master => master -> [Text] -> W.Application + sendRedirect y segments' env sendResponse = + sendResponse $ W.responseLBS status + [ ("Content-Type", "text/plain") + , ("Location", BL.toStrict $ toLazyByteString dest') + ] "Redirecting" + where + -- Ensure that non-GET requests get redirected correctly. See: + -- https://github.com/yesodweb/yesod/issues/951 + status + | W.requestMethod env == "GET" = status301 + | otherwise = status307 + + dest = joinPath y (resolveApproot y env) segments' [] + dest' = + if S.null (W.rawQueryString env) + then dest + else dest `mappend` + byteString (W.rawQueryString env) diff --git a/src/Yesod/Core/Class/Dispatch/ToParentRoute.hs b/src/Yesod/Core/Class/Dispatch/ToParentRoute.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Core/Class/Dispatch/ToParentRoute.hs @@ -0,0 +1,18 @@ +{-# language FlexibleContexts #-} + +module Yesod.Core.Class.Dispatch.ToParentRoute where + +import Yesod.Routes.Class + +-- | Reconstruct a full parent route from a nested route fragment and its +-- 'ParentArgs' (the dynamic pieces consumed by the ancestor parents). This is +-- what lets a fragment dispatched in its own module be rendered back into the +-- master site's @'Route' ('ParentSite' a)@. +-- +-- @since 1.7.0.0 +class (RenderRoute (ParentSite a)) => ToParentRoute a where + -- | @since 1.7.0.0 + toParentRoute :: ParentArgs a -> a -> Route (ParentSite a) + +instance (RenderRoute a) => ToParentRoute (Route a) where + toParentRoute _ = id diff --git a/src/Yesod/Core/Dispatch.hs b/src/Yesod/Core/Dispatch.hs --- a/src/Yesod/Core/Dispatch.hs +++ b/src/Yesod/Core/Dispatch.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -22,6 +24,21 @@ , mkYesodDispatch , mkYesodDispatchOpts , mkYesodSubDispatch + , mkYesodSubDispatchInstance + , mkYesodSubDispatchInstanceOpts + -- *** Splitting a subsite's nested routes across modules + -- + -- | These re-exports let a separately-compiled module generate a + -- subsite's @YesodSubDispatchNested@ instance by hand (see the + -- subsite-route-splitting recipe in @docs/split-route-compilation.md@). + -- 'mkNestedSubDispatchInstance' takes the resources as + -- @['ResourceTree' 'String']@ (the 'parseRoutes' quasi-quoter's output) + -- and parses them internally, so no manual type-parsing is needed. + + -- | @since 1.7.0.0 + , mkNestedSubDispatchInstance + -- | @since 1.7.0.0 + , TyArgs (..) -- *** Route generation options , RouteOpts , defaultOpts @@ -29,7 +46,10 @@ , setShowDerived , setReadDerived , setCreateResources + , setFocusOnNestedRoute + , unsetFocusOnNestedRoute , setParameterizedSubroute + , setNestedRouteFallthrough -- *** Helpers , defaultGen , getGetMaxExpires @@ -40,12 +60,18 @@ -- * Convert to WAI , toWaiApp , toWaiAppPlain + , UrlToDispatch(..) + , mkYesodRunnerEnv + , toWaiAppPlainNested , toWaiAppYre + , toWaiAppYreNested , warp , warpDebug , warpEnv , mkDefaultMiddlewares , defaultMiddlewaresNoLogging + -- * Subsite nested dispatch + , YesodSubDispatchNested (..) -- * WAI subsites , WaiSubsite (..) , WaiSubsiteWithAuth (..) @@ -54,6 +80,8 @@ import Prelude hiding (exp) import Yesod.Core.Internal.TH import Language.Haskell.TH.Syntax (qLocation) +import Data.Proxy +import Yesod.Routes.Class import Web.PathPieces @@ -64,23 +92,21 @@ import Data.Bits ((.|.), finiteBitSize, shiftL) import Data.Text (Text) import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as S8 -import Data.ByteString.Builder (byteString, toLazyByteString) #if !MIN_VERSION_wai_extra(3,1,14) import Data.Default (def) #endif -import Network.HTTP.Types (status301, status307) import Yesod.Routes.Parse +import Yesod.Routes.TH (TyArgs (..)) import Yesod.Core.Types import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch -import Yesod.Core.Internal.Run import Text.Read (readMaybe) import System.Environment (getEnvironment) import System.Entropy (getEntropy) import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq) import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) +import Yesod.Core.Class.Dispatch.ToParentRoute import Network.Wai.Middleware.Autohead import Network.Wai.Middleware.AcceptOverride @@ -105,17 +131,52 @@ -- used middlewares, please use 'toWaiApp'. toWaiAppPlain :: YesodDispatch site => site -> IO W.Application toWaiAppPlain site = do + yre <- mkYesodRunnerEnv site + return $ toWaiAppYre yre + +-- | Construct a 'YesodRunnerEnv' for a site, initializing its logger, session +-- backend, and other runtime state. This is the environment threaded through +-- dispatch; 'toWaiAppPlain' and friends build one for you, but it is exposed so +-- callers can construct and reuse a runner environment directly. +-- +-- @since 1.7.0.0 +mkYesodRunnerEnv :: Yesod site => site -> IO (YesodRunnerEnv site) +mkYesodRunnerEnv site = do logger <- makeLogger site sb <- makeSessionBackend site getMaxExpires <- getGetMaxExpires - return $ toWaiAppYre YesodRunnerEnv - { yreLogger = logger - , yreSite = site - , yreSessionBackend = sb - , yreGen = defaultGen - , yreGetMaxExpires = getMaxExpires - } + pure YesodRunnerEnv + { yreLogger = logger + , yreSite = site + , yreSessionBackend = sb + , yreGen = defaultGen + , yreGetMaxExpires = getMaxExpires + } +-- | Convert the given argument into a WAI application, executable with any WAI +-- handler. This function will provide no middlewares; if you want commonly +-- used middlewares, please use 'toWaiApp'. +-- +-- This function allows you to create an 'Application' that only responds +-- to a subset of the 'site' routes. This is really only useful for writing +-- tests, but it does allow you to write tests that only depend on a subset +-- of the handlers instead of all handlers. +-- +-- @since 1.7.0.0 +toWaiAppPlainNested + :: ( site ~ ParentSite route + , Yesod site + , YesodDispatchNested route + , ToParentRoute route + ) + => Proxy route + -> ParentArgs route + -> site + -> IO W.Application +toWaiAppPlainNested proxy parentArgs site = do + yre <- mkYesodRunnerEnv site + return $ toWaiAppYreNested proxy parentArgs yre + -- | Generate a random number uniformly distributed in the full range -- of 'Int'. -- @@ -138,33 +199,7 @@ -- -- @since 1.4.29 toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application -toWaiAppYre yre req = - case cleanPath site $ W.pathInfo req of - Left pieces -> sendRedirect site pieces req - Right pieces -> yesodDispatch yre req - { W.pathInfo = pieces - } - where - site = yreSite yre - sendRedirect :: Yesod master => master -> [Text] -> W.Application - sendRedirect y segments' env sendResponse = - sendResponse $ W.responseLBS status - [ ("Content-Type", "text/plain") - , ("Location", BL.toStrict $ toLazyByteString dest') - ] "Redirecting" - where - -- Ensure that non-GET requests get redirected correctly. See: - -- https://github.com/yesodweb/yesod/issues/951 - status - | W.requestMethod env == "GET" = status301 - | otherwise = status307 - - dest = joinPath y (resolveApproot y env) segments' [] - dest' = - if S.null (W.rawQueryString env) - then dest - else dest `mappend` - byteString (W.rawQueryString env) +toWaiAppYre = toWaiAppYreNested (Proxy :: Proxy (Route site)) () -- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This -- set may change with future releases, but currently covers: diff --git a/src/Yesod/Core/Handler.hs b/src/Yesod/Core/Handler.hs --- a/src/Yesod/Core/Handler.hs +++ b/src/Yesod/Core/Handler.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -263,6 +264,8 @@ import qualified Data.Word8 as W8 import qualified Data.Foldable as Fold import Control.Monad.Logger (MonadLogger, logWarnS) +import Yesod.Routes.Class (WithParentArgs(..), ParentSite(..)) +import Yesod.Core.Class.Dispatch.ToParentRoute (ToParentRoute(..)) type HandlerT site (m :: Type -> Type) = HandlerFor site {-# DEPRECATED HandlerT "Use HandlerFor directly" #-} @@ -1031,6 +1034,17 @@ toTextUrl url = do r <- getUrlRender return $ r url + +instance + ( RedirectUrl master (Route master) + , ParentSite url ~ master + , ToParentRoute url + ) + => + RedirectUrl master (WithParentArgs url) + where + toTextUrl (WithParentArgs args url) = + toTextUrl (toParentRoute args url) instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where toTextUrl (url, params) = do diff --git a/src/Yesod/Core/Internal/TH.hs b/src/Yesod/Core/Internal/TH.hs --- a/src/Yesod/Core/Internal/TH.hs +++ b/src/Yesod/Core/Internal/TH.hs @@ -1,9 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Yesod.Core.Internal.TH @@ -33,9 +34,11 @@ , mkDispatchInstance , mkYesodSubDispatch + , mkYesodSubDispatchInstance + , mkYesodSubDispatchInstanceOpts + , mkNestedSubDispatchInstance , subTopDispatch - , instanceD , RouteOpts , defaultOpts @@ -43,30 +46,28 @@ , setShowDerived , setReadDerived , setCreateResources + , setFocusOnNestedRoute + , unsetFocusOnNestedRoute , setParameterizedSubroute + , setNestedRouteFallthrough ) where import Prelude hiding (exp) import Yesod.Core.Handler - import Language.Haskell.TH hiding (cxt, instanceD) import Language.Haskell.TH.Syntax - -import qualified Network.Wai as W - import Data.ByteString.Lazy.Char8 () import Data.List (foldl') -import Control.Monad (replicateM, void) -import Text.Parsec (parse, many1, many, eof, try, option, sepBy1) -import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char) - +import Data.Maybe +import Control.Monad import Yesod.Routes.TH +import Yesod.Routes.TH.Dispatch + (parseYesodName, mkYesodSubDispatchWithDelegate, SameSpliceNestedInstances (..)) +import Yesod.Routes.TH.Internal (instanceD, typeArity, assertNestedSubArity, ArityCallSite(..), SubsiteName(..), SubsiteArity(..), resolveRouteCon, nestedInstanceExists) import Yesod.Routes.Parse -import Yesod.Core.Content (ToTypedContent (..)) import Yesod.Core.Types -import Yesod.Core.Class.Dispatch -import Yesod.Core.Internal.Run +import Yesod.Core.Class.Dispatch (YesodSubDispatch(..), YesodSubDispatchNested(..)) -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter. @@ -125,6 +126,15 @@ mkYesodSubDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name True return resS +-- | Run 'parseYesodName' in 'Q', failing the splice with the parse error +-- instead of returning an 'Either'. Shared by the @mkYesod@ and +-- @mkYesodSubDispatch@ entry points. +parseYesodNameQ :: String -> Q (String, [String], [[String]]) +parseYesodNameQ name = + case parseYesodName name of + Left err -> fail err + Right a -> pure a + -- | Parses contexts and type arguments out of name before generating TH. mkYesodWithParser :: String -- ^ foundation type -> Bool -- ^ is this a subsite @@ -143,40 +153,9 @@ -> [ResourceTree String] -> Q([Dec],[Dec]) mkYesodWithParserOpts opts name isSub f resS = do - let (name', rest, cxt) = case parse parseName "" name of - Left err -> error $ show err - Right a -> a - mkYesodGeneralOpts opts cxt name' rest isSub f resS - - where - parseName = do - cxt <- option [] parseContext - name' <- parseWord - args <- many parseWord - spaces - eof - return ( name', args, cxt) - - parseWord = do - spaces - many1 alphaNum - - parseContext = try $ do - cxts <- parseParen parseContexts - spaces - _ <- string "=>" - return cxts - - parseParen p = do - spaces - _ <- char '(' - r <- p - spaces - _ <- char ')' - return r + (name', rest, cxt) <- parseYesodNameQ name - parseContexts = - sepBy1 (many1 parseWord) (spaces >> char ',' >> return ()) + mkYesodGeneralOpts opts cxt name' rest isSub f resS -- | See 'mkYesodData'. @@ -190,6 +169,17 @@ mkYesodDispatchOpts opts name = fmap snd . mkYesodWithParserOpts opts name False return +-- | Build an instance context ('Cxt') from the parsed @=>@ class-application +-- groups produced by 'parseYesodName'. Each group is a class name applied to +-- type arguments, e.g. @["MyClass","a"]@ becomes @MyClass a@. Shared by +-- 'mkYesodGeneralOpts' and 'mkYesodSubDispatchInstanceOpts'. +buildAppCxt :: [[String]] -> Q Cxt +buildAppCxt = traverse $ \ctxs -> + case ctxs of + c:rest -> + pure $ foldl' (\acc v -> acc `AppT` fst (nameToType v)) (ConT $ mkName c) rest + [] -> fail $ "mkYesod: empty type-class context in route definition: " ++ show ctxs + -- | Get the Handler and Widget type synonyms for the given site. masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself? masterTypeSyns vs site = @@ -209,11 +199,84 @@ -> Q([Dec],[Dec]) mkYesodGeneral = mkYesodGeneralOpts defaultOpts +-- | Convert the parsed-from-source 'String' route types into real 'Type's at a +-- splice site. A malformed type or an unclosed @#{…}@ bracket surfaces as an +-- attributed compile error (via 'fail') rather than a raw 'error' thrown lazily +-- when the resulting tree is forced. This is the single 'String'-to-'Type' +-- boundary: callers downstream only ever handle @['ResourceTree' 'Type']@. +parseResourceTypes :: [ResourceTree String] -> Q [ResourceTree Type] +parseResourceTypes = traverse (traverse (\s -> dropBracketM s >>= parseTypeM)) + +-- | Generate a @YesodSubDispatchNested@ instance for a nested route within a +-- subsite, for hand-written split-route modules (see the subsite-splitting +-- recipe in @docs/split-route-compilation.md@). +-- +-- Takes the resources as @['ResourceTree' 'String']@ — exactly the form the +-- @parseRoutes@ quasi-quoter produces — and parses them to 'Type' internally +-- via 'parseResourceTypes', so the caller never touches the partial +-- 'parseType'\/'dropBracket'. A malformed type fails the splice with an +-- attributed error instead. +-- +-- @since 1.7.0.0 +mkNestedSubDispatchInstance + :: RouteOpts + -> String -- ^ target nested route name + -> Cxt -- ^ instance context + -> TyArgs -- ^ type arguments + -> (Exp -> Q Exp) -- ^ unwrapper + -> [ResourceTree String] -- ^ all resources (as parsed from source) + -> Q [Dec] +mkNestedSubDispatchInstance routeOpts target cxt tyargs unwrapper resS = do + res <- parseResourceTypes resS + -- Guard the top target's arity here. 'mkNestedDispatchInstanceWith' only + -- arity-checks nested *children*, so without this a hand-written recipe + -- pairing a parameterized subsite with an unparameterized target datatype + -- would apply the subsite's type args to a kind-'Type' head and surface a + -- cryptic kind error from generated code rather than this actionable one. + -- A no-op when the datatype is not in scope (unknowable arity) or when the + -- arities match. + rc <- resolveRouteCon target + assertNestedSubArity SubsiteCall (SubsiteName target) + (SubsiteArity (tyArgsArity tyargs)) rc + mkNestedDispatchInstanceWith SubsiteNested Nothing + routeOpts target cxt tyargs unwrapper res + +-- | The resolved foundation type shared by 'mkYesodGeneralOpts' and +-- 'mkYesodSubDispatchInstanceOpts': the @boundNames@ from the explicitly-written +-- type args plus enough fresh @t@ variables to fill the reified arity, the fully +-- applied @site@ type, and the parsed resources. The callers differ only in how +-- they roll these into 'TyArgs' (and the synonym-head vars), so that part stays +-- with each caller. +data ResolvedFoundation = ResolvedFoundation + { rfBoundNames :: [(Type, Name)] -- ^ explicitly-written type args + , rfFillVars :: [Name] -- ^ fresh vars filling the reified arity + , rfSite :: Type -- ^ the fully applied site type + , rfResources :: [ResourceTree Type] + } + +resolveFoundation :: String -> [String] -> [ResourceTree String] -> Q ResolvedFoundation +resolveFoundation namestr mtys resS = do + mname <- lookupTypeName namestr + arity <- maybe (pure 0) typeArity mname + let name = mkName namestr + -- Generate as many variable names as the arity indicates + vns <- replicateM (arity - length mtys) $ newName "t" + let boundNames = fmap nameToType mtys + argtypes = fmap fst boundNames ++ fmap VarT vns + site = foldl' AppT (ConT name) argtypes + res <- parseResourceTypes resS + pure ResolvedFoundation + { rfBoundNames = boundNames + , rfFillVars = vns + , rfSite = site + , rfResources = res + } + -- | -- -- @since 1.6.25.0 mkYesodGeneralOpts :: RouteOpts -- ^ Options to adjust route creation - -> [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances. + -> [[String]] -- ^ Application context. Used in RenderRoute, RouteAttrs, and ParseRoute instances. -> String -- ^ foundation type -> [String] -- ^ arguments for the type -> Bool -- ^ is this a subsite @@ -221,41 +284,52 @@ -> [ResourceTree String] -> Q([Dec],[Dec]) mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do - let appCxt = fmap (\ctxs -> - case ctxs of - c:rest -> - foldl' (\acc v -> acc `AppT` fst (nameToType v)) (ConT $ mkName c) rest - [] -> error $ "Bad context: " ++ show ctxs - ) appCxt' - mname <- lookupTypeName namestr - arity <- case mname of - Just name -> do - info <- reify name - return $ - case info of - TyConI dec -> - case dec of - DataD _ _ vs _ _ _ -> length vs - NewtypeD _ _ vs _ _ _ -> length vs - TySynD _ vs _ -> length vs - _ -> 0 - _ -> 0 - _ -> return 0 - let name = mkName namestr - -- Generate as many variable names as the arity indicates - vns <- replicateM (arity - length mtys) $ newName "t" - -- types that you apply to get a concrete site name - let boundNames = fmap nameToType mtys - argtypes = fmap fst boundNames ++ fmap VarT vns + appCxt <- buildAppCxt appCxt' + foundation <- resolveFoundation namestr mtys resS + -- The explicitly-written args plus the fresh vars filling the reified + -- arity. Both are part of the site's full application ('rfSite'), so both + -- must travel in the 'TyArgs' handed to 'discoveryMode' and the generators + -- — otherwise a parameterized foundation invoked without explicit type args + -- would be misclassified as monomorphic and emit ill-scoped nested + -- instances. + let fillNames = fmap (\v -> (VarT v, v)) (rfFillVars foundation) + tyArgs = toTyArgs (rfBoundNames foundation ++ fillNames) -- typevars that should appear in synonym head - let argvars = (fmap mkName . filter isTvar) mtys ++ vns - -- Base type (site type with variables) - let site = foldl' AppT (ConT name) argtypes - res = map (fmap (parseType . dropBracket)) resS - renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt boundNames site res - routeAttrsDec <- mkRouteAttrsInstance appCxt site res - dispatchDec <- mkDispatchInstance site appCxt f res - parseRoute <- mkParseRouteInstance appCxt site res + let argvars = (fmap mkName . filter isTvar) mtys ++ rfFillVars foundation + renderRouteDec <- + mkRenderRouteInstanceOpts opts appCxt tyArgs (rfSite foundation) (rfResources foundation) + routeAttrsDec <- + case roFocusOnNestedRoute opts of + Nothing -> do + -- The flat 'RouteAttrs (Route site)' instance, plus — in + -- nested-discovery mode — a 'RouteAttrsNested' instance for each + -- child fragment, mirroring the RenderRouteNested / + -- ParseRouteNested / YesodDispatchNested instances generated for + -- the same children. Without this, 'routeAttrsNested ChildR' + -- would fail to resolve for a single-module 'mkYesod' site even + -- though the other nested-delegation methods resolve. + flatAttrs <- mkRouteAttrsInstance appCxt (rfSite foundation) (rfResources foundation) + nestedAttrs <- + case discoveryMode opts tyArgs of + NestedDiscovery -> + mkRouteAttrsNestedInstances appCxt tyArgs (rfResources foundation) + InlineCompat -> pure [] + pure (flatAttrs : nestedAttrs) + Just target -> + -- Apply the site's type arguments to the focused child's + -- constructor, matching the focused ParseRoute / RenderRoute + -- paths; a bare 'ConT' here is a kind error for a + -- parameterized site. + mkRouteAttrsInstanceFor + appCxt + (applyTyArgs (ConT (mkName target)) tyArgs) + target + (rfResources foundation) + + dispatchDec <- + mkDispatchInstance opts (rfSite foundation) appCxt tyArgs f (rfResources foundation) + parseRouteDec <- + mkParseRouteInstanceOpts opts tyArgs appCxt (rfSite foundation) (rfResources foundation) let rname = mkName $ "resources" ++ namestr resourcesDec <- if shouldCreateResources opts @@ -268,99 +342,149 @@ else do pure [] let dataDec = concat - [ [parseRoute] + [ parseRouteDec , renderRouteDec - , [routeAttrsDec] - , resourcesDec - , if isSub then [] else masterTypeSyns argvars site + , routeAttrsDec + , if isJust (roFocusOnNestedRoute opts) then [] else resourcesDec + , if isSub || isJust (roFocusOnNestedRoute opts) + then [] + else masterTypeSyns argvars (rfSite foundation) ] return (dataDec, dispatchDec) +-- | Generate both 'YesodSubDispatch' and 'YesodSubDispatchNested' instances +-- for a parameterized subsite. This is the subsite equivalent of using +-- @mkYesod@ for top-level sites. +-- +-- Usage: +-- +-- @ +-- mkYesodSubDispatchInstance "(MyClass a) => MySub a" resourcesMySub +-- @ +-- +-- This generates: +-- +-- 1. A 'YesodSubDispatch' instance using 'mkYesodSubDispatch' +-- 2. 'YesodSubDispatchNested' instances for any nested route fragments +-- +-- The generated instances quantify over the @master@ site and constrain it +-- only through the subsite's own class. For a parameterized subsite this +-- normally means the subsite's class carries a @subsite -> master@ functional +-- dependency (so @master@ is determined) and the using module enables +-- @UndecidableInstances@ (the instance contexts mention type-family +-- applications and non-variable arguments), along with @FlexibleContexts@, +-- @FlexibleInstances@, @MultiParamTypeClasses@ and @TypeFamilies@. The nested +-- route datatype must also declare exactly as many type parameters as the +-- subsite has type arguments (see the arity note below). +-- +-- @since 1.7.0.0 +mkYesodSubDispatchInstance + :: String -- ^ Foundation type with optional context, e.g. @"(MyClass a) => MySub a"@ + -> [ResourceTree String] -- ^ Resources (e.g. @resourcesMySub@) + -> Q [Dec] +mkYesodSubDispatchInstance = mkYesodSubDispatchInstanceOpts defaultOpts -mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b -mkMDS f rh sd = MkDispatchSettings - { mdsRunHandler = rh - , mdsSubDispatcher = sd - , mdsGetPathInfo = [|W.pathInfo|] - , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] - , mdsMethod = [|W.requestMethod|] - , mds404 = [|void notFound|] - , mds405 = [|void badMethod|] - , mdsGetHandler = defaultGetHandler - , mdsUnwrapper = f - } +-- | Like 'mkYesodSubDispatchInstance', but takes a 'RouteOpts' so a subsite can +-- control nested-route generation — most usefully 'setNestedRouteFallthrough' +-- (which 'mkYesodSubDispatchInstance' leaves at its default of 'False'). The +-- flag is threaded into both the @yesodSubDispatch@ body (so the subsite's own +-- top-level parent clauses fall through to later siblings on an inner miss) and +-- the generated @YesodSubDispatchNested@ fragment instances. +-- +-- @since 1.7.0.0 +mkYesodSubDispatchInstanceOpts + :: RouteOpts + -> String -- ^ Foundation type with optional context, e.g. @"(MyClass a) => MySub a"@ + -> [ResourceTree String] -- ^ Resources (e.g. @resourcesMySub@) + -> Q [Dec] +mkYesodSubDispatchInstanceOpts opts nameStr resS = do + -- Parse the name string to extract context, type name, and type args + -- (the same parser the top-level mkYesod entry points use). + (namestr, mtys, appCxt') <- parseYesodNameQ nameStr --- | If the generation of @'YesodDispatch'@ instance require finer --- control of the types, contexts etc. using this combinator. You will --- hardly need this generality. However, in certain situations, like --- when writing library/plugin for yesod, this combinator becomes --- handy. -mkDispatchInstance :: Type -- ^ The master site type - -> Cxt -- ^ Context of the instance - -> (Exp -> Q Exp) -- ^ Unwrap handler - -> [ResourceTree c] -- ^ The resource - -> DecsQ -mkDispatchInstance master cxt f res = do - clause' <- - mkDispatchClause - (mkMDS - f - [|yesodRunner|] - [|\parentRunner getSub toParent env -> yesodSubDispatch - YesodSubRunnerEnv - { ysreParentRunner = parentRunner - , ysreGetSub = getSub - , ysreToParentRoute = toParent - , ysreParentEnv = env - } - |]) - res - let thisDispatch = FunD 'yesodDispatch [clause'] - return [instanceD cxt yDispatch [thisDispatch]] - where - yDispatch = ConT ''YesodDispatch `AppT` master + appCxt <- buildAppCxt appCxt' + foundation <- resolveFoundation namestr mtys resS + -- The explicitly-written args plus the fresh vars filling the reified + -- arity. Both are part of the subsite's full application ('rfSite'), so both + -- must travel in the 'TyArgs' handed to 'discoveryMode' and the generators + -- — otherwise a parameterized subsite invoked without explicit type args + -- (e.g. @mkYesodSubDispatchInstance "MySub"@ for @MySub a@) would be + -- misclassified as monomorphic and emit ill-scoped nested instances. This + -- mirrors the 'fillNames' fix in 'mkYesodGeneralOpts'. + let fillNames = fmap (\v -> (VarT v, v)) (rfFillVars foundation) + tyArgs = toTyArgs (rfBoundNames foundation ++ fillNames) -mkYesodSubDispatch :: [ResourceTree a] -> Q Exp -mkYesodSubDispatch res = do - clause' <- - mkDispatchClause - (mkMDS - return - [|subHelper|] - [|subTopDispatch|]) - res - inner <- newName "inner" - let innerFun = FunD inner [clause'] - helper <- newName "helper" - let fun = FunD helper - [ Clause - [] - (NormalB $ VarE inner) - [innerFun] - ] - return $ LetE [fun] (VarE helper) + -- Generate the YesodSubDispatch instance + masterN <- newName "master" + let masterT = VarT masterN + -- Thread the opts (in particular 'roNestedRouteFallthrough') into the + -- generated @yesodSubDispatch@ body so a subsite's own top-level parent + -- clauses honor 'setNestedRouteFallthrough', matching the top-level + -- 'mkTopLevelDispatchInstance' path. 'GeneratesNestedInstances': this + -- entry point emits a 'YesodSubDispatchNested' instance per parent in + -- this same splice (below), so the flat @yesodSubDispatch@ body + -- delegates each parent to that instance instead of inlining the + -- subtree dispatch (which the nested instance would re-emit), avoiding + -- the doubled codegen. This mirrors 'mkTopLevelDispatchInstance' on the + -- top-level path. Standalone 'mkYesodSubDispatch'/'mkYesodSubDispatchWith' + -- stay at 'NoSameSpliceNestedInstances'. + subDispatchExp = + mkYesodSubDispatchWithDelegate + GeneratesNestedInstances + opts + (rfResources foundation) + subDispatchBody <- subDispatchExp + let yesodSubDispatchInst = instanceD + appCxt + (ConT ''YesodSubDispatch `AppT` rfSite foundation `AppT` masterT) + [ FunD 'yesodSubDispatch + [ Clause [] (NormalB subDispatchBody) [] ] + ] + -- The top-level nested parents, each of which gets a + -- YesodSubDispatchNested instance generated below. + let nestedNames = [ n | ResourceParent n _ _ _ _ <- rfResources foundation ] -subTopDispatch :: - (YesodSubDispatch sub master) => - (forall content. ToTypedContent content => - SubHandlerFor child master content -> - YesodSubRunnerEnv child master -> - Maybe (Route child) -> - W.Application - ) -> - (mid -> sub) -> - (Route sub -> Route mid) -> - YesodSubRunnerEnv mid master -> - W.Application -subTopDispatch _ getSub toParent env = yesodSubDispatch - (YesodSubRunnerEnv - { ysreParentRunner = ysreParentRunner env - , ysreGetSub = getSub . ysreGetSub env - , ysreToParentRoute = ysreToParentRoute env . toParent - , ysreParentEnv = ysreParentEnv env - }) + nestedInstances <- fmap mconcat $ forM nestedNames $ \nestedName -> do + -- Resolve the nested datatype once and reuse it for both the + -- "instance already exists?" probe and the arity check below. + -- 'nestedInstanceExists' saturates by the datatype's own reified arity, + -- so it can't throw a kind error on an arity-mismatched in-scope + -- datatype — which is exactly the misuse the 'checkNestedSubArity' + -- below diagnoses. That keeps the friendly arity check reachable + -- instead of being preempted by a cryptic kind error from the probe. + rc <- resolveRouteCon nestedName + instanceExists <- nestedInstanceExists ''YesodSubDispatchNested rc + if instanceExists + then pure [] + else do + -- This API targets parameterized subsites whose nested subroute + -- datatypes carry the parent's type arguments (the subsite's + -- 'tyArgs' are applied to the nested datatype directly below). + -- Guard the misuse where the + -- subsite is parameterized but the nested datatype is not: + -- otherwise applying the subsite's type args to a kind-'Type' + -- datatype produces a cryptic kind error from generated code. + -- Only check when the datatype actually resolved — an + -- unresolved name has no knowable arity (defaulting it to 0 + -- would wrongly report "0 type parameter(s)"), and downstream + -- codegen reports the not-in-scope case on its own. + assertNestedSubArity + SubsiteCall + (SubsiteName namestr) + (SubsiteArity (tyArgsArity tyArgs)) + rc + -- Call the worker directly with the foundation's + -- already-parsed 'Type' resources, rather than re-parsing the + -- 'String' resources through the public 'mkNestedSubDispatchInstance'. + -- The generator applies 'tyArgs' to the nested datatype directly + -- and never consults 'roParameterizedSubroute' (it only reads + -- 'roNestedRouteFallthrough'), so passing 'opts' through + -- unchanged is correct — forcing 'setParameterizedSubroute' here + -- was a no-op. + mkNestedDispatchInstanceWith SubsiteNested Nothing + opts + nestedName appCxt tyArgs return (rfResources foundation) -instanceD :: Cxt -> Type -> [Dec] -> Dec -instanceD = InstanceD Nothing + return $ yesodSubDispatchInst : nestedInstances diff --git a/src/Yesod/Core/Types/Content.hs b/src/Yesod/Core/Types/Content.hs --- a/src/Yesod/Core/Types/Content.hs +++ b/src/Yesod/Core/Types/Content.hs @@ -13,7 +13,7 @@ -- into memory by default in order to catch imprecise exceptions -- before beginning to respond. If you are confident you don't have -- imprecise exceptions, you may disable this by wrapping the - -- `ToContent` data in `DontFullyEvaluate`.- + -- `ToContent` data in `DontFullyEvaluate`. | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ()) | ContentFile !FilePath !(Maybe FilePart) | ContentDontEvaluate !Content diff --git a/src/Yesod/Routes/Class.hs b/src/Yesod/Routes/Class.hs --- a/src/Yesod/Routes/Class.hs +++ b/src/Yesod/Routes/Class.hs @@ -1,14 +1,23 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} module Yesod.Routes.Class ( RenderRoute (..) , ParseRoute (..) , RouteAttrs (..) + , -- * For nested routes and splitting files + RenderRouteNested (..) + , ParseRouteNested (..) + , RouteAttrsNested (..) + , WithParentArgs (..) ) where import Data.Text (Text) import Data.Set (Set) +import Data.Kind (Type) class Eq (Route a) => RenderRoute a where -- | The associated with a site argument. @@ -16,10 +25,97 @@ renderRoute :: Route a -> ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value. +-- | This datatype wraps up the 'ParentArgs' for a route fragment with the +-- route fragment itself. A route fragment with its parent arguments can +-- be rendered and dispatched on. +-- +-- @since 1.7.0.0 +data WithParentArgs a = WithParentArgs + { theParentArgs :: ParentArgs a + , parentArgsFor :: a + } + +deriving stock instance (Eq (ParentArgs a), Eq a) => Eq (WithParentArgs a) + +instance (Eq (ParentArgs a), RenderRouteNested a) => RenderRouteNested (WithParentArgs a) where + type ParentSite (WithParentArgs a) = ParentSite a + type ParentArgs (WithParentArgs a) = () + + renderRouteNested () (WithParentArgs parentArgs a) = + renderRouteNested parentArgs a + +-- | This class acts as a delegation class for 'RenderRoute' on nested +-- route fragments. +-- +-- @since 1.7.0.0 +class Eq a => RenderRouteNested a where + -- | The site type for a given route fragment. + -- + -- @since 1.7.0.0 + type ParentSite a :: Type + + -- | The 'ParentArgs' are the route fragments necessary to call the + -- dispatched route that are not part of the route fragments used in + -- parsing the route. + -- + -- @since 1.7.0.0 + type ParentArgs a :: Type + type ParentArgs a = () + + -- | Render the fragment of the route. To form a complete route, you'll + -- need to 'mappend' this with the result from the parent 'renderRoute' + -- or 'renderRouteNested' call. + -- + -- @since 1.7.0.0 + renderRouteNested :: ParentArgs a -> a -> ([Text], [(Text, Text)]) + +instance (RenderRoute site) => RenderRouteNested (Route site) where + type ParentSite (Route site) = site + type ParentArgs (Route site) = () + + renderRouteNested () a = renderRoute a + class RenderRoute a => ParseRoute a where parseRoute :: ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value. -> Maybe (Route a) +-- | Like 'RenderRouteNested', this acts as a delegation class for nested +-- route fragments. +-- +-- Note that 'parseRouteNested' and 'renderRouteNested' are /not/ inverses, by +-- design. 'renderRouteNested' consumes the @'ParentArgs' a@ (the parent's +-- dynamic pieces) to produce a complete path, whereas 'parseRouteNested' +-- recovers only the fragment @a@ and never the 'ParentArgs' — the parent is +-- responsible for those. So @'parseRouteNested' p@ followed by +-- @'renderRouteNested' args@ round-trips the /fragment/ portion of @p@ only, +-- with @args@ supplied separately by the caller. +-- +-- @since 1.7.0.0 +class RenderRouteNested a => ParseRouteNested a where + -- | Parse a route fragment from a path. Like 'parseRoute', but produces + -- the fragment @a@ directly rather than a complete 'Route'; the parent is + -- responsible for constructing the full route from the result. + -- + -- @since 1.7.0.0 + parseRouteNested + :: ([Text], [(Text, Text)]) + -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value. + -- + -- Unlike for 'parseRoute', this will not include URL fragments as + -- part of parent routes. It is expected that parents will take the + -- resulting @a@ and construct the parent from that. + -> Maybe a + class RenderRoute a => RouteAttrs a where routeAttrs :: Route a -> Set Text -- ^ A set of . + +-- | Like 'RenderRouteNested', this acts as a delegation class for nested +-- route fragments to provide 'RouteAttrs'. +-- +-- @since 1.7.0.0 +class RenderRouteNested a => RouteAttrsNested a where + -- | Retrieve the 'RouteAttrs' for a given route fragment. + -- + -- @since 1.7.0.0 + routeAttrsNested :: a -> Set Text diff --git a/src/Yesod/Routes/Overlap.hs b/src/Yesod/Routes/Overlap.hs --- a/src/Yesod/Routes/Overlap.hs +++ b/src/Yesod/Routes/Overlap.hs @@ -24,7 +24,7 @@ , fHasSuffix = hasSuffix $ ResourceLeaf r , fCheck = check && resourceCheck r } - go names pieces check (ResourceParent newname check' newpieces children) = + go names pieces check (ResourceParent newname check' _attrs newpieces children) = concatMap (go names' pieces' (check && check')) children where names' = names . (newname:) @@ -57,10 +57,18 @@ piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY piecesOverlap :: Piece t -> Piece t -> Bool --- Statics only match if they equal. Dynamics match with anything +-- Statics only match if they are equal. A dynamic piece is treated as +-- overlapping with anything: although at runtime a typed dynamic (e.g. an +-- 'Int') only matches inputs that parse to its type, the overlap check is +-- intentionally conservative and never inspects the dynamic-piece type — it is +-- parametric in @t@ (see 'findOverlapNames'). Reporting a possible overlap that +-- cannot actually occur is harmless; missing a real one would not be. piecesOverlap (Static x) (Static y) = x == y piecesOverlap _ _ = True +-- | The overlap check never inspects the dynamic-piece type, so this is +-- parametric in it (the reported names come from 'resourceName', always a +-- 'String'). findOverlapNames :: [ResourceTree t] -> [(String, String)] findOverlapNames = map go . findOverlapsF . filter fCheck . concatMap Yesod.Routes.Overlap.flatten diff --git a/src/Yesod/Routes/Parse.hs b/src/Yesod/Routes/Parse.hs --- a/src/Yesod/Routes/Parse.hs +++ b/src/Yesod/Routes/Parse.hs @@ -9,9 +9,11 @@ , parseRoutesNoCheck , parseRoutesFileNoCheck , parseType + , parseTypeM , parseTypeTree , TypeTree (..) , dropBracket + , dropBracketM , nameToType , isTvar ) where @@ -33,10 +35,10 @@ parseRoutes = QuasiQuoter { quoteExp = x } where x s = do - let res = resourcesFromString s + res <- resourcesFromString s case findOverlapNames res of [] -> lift res - z -> error $ unlines $ "Overlapping routes: " : map show z + z -> fail $ unlines $ "Overlapping routes: " : map show z -- | Same as 'parseRoutes', but uses an external file instead of quasiquotation. -- @@ -65,20 +67,24 @@ -- | Same as 'parseRoutes', but performs no overlap checking. parseRoutesNoCheck :: QuasiQuoter parseRoutesNoCheck = QuasiQuoter - { quoteExp = lift . resourcesFromString + { quoteExp = \s -> resourcesFromString s >>= lift } -- | Converts a multi-line string to a set of resources. See documentation for --- the format of this string. This is a partial function which calls 'error' on --- invalid input. -resourcesFromString :: String -> [ResourceTree String] +-- the format of this string. Runs in any 'MonadFail' (e.g. the 'Q' monad of a +-- splice) and reports malformed input through 'fail', so diagnostics are +-- attributed to the splice rather than surfacing as a raw 'error' call stack. +resourcesFromString :: MonadFail m => String -> m [ResourceTree String] resourcesFromString = - fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r') + fmap fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r') where - parse _ [] = ([], []) + parse _ [] = pure ([], []) parse indent (thisLine:otherLines) - | length spaces < indent = ([], thisLine : otherLines) - | otherwise = (this others, remainder) + | length spaces < indent = pure ([], thisLine : otherLines) + | otherwise = do + (this, otherLines') <- classify + (others, remainder) <- parse indent otherLines' + pure (this others, remainder) where parseAttr ('!':x) = Just x parseAttr _ = Nothing @@ -94,58 +100,55 @@ go front (x:xs) = go (front . (x:)) xs spaces = takeWhile (== ' ') thisLine - (others, remainder) = parse indent otherLines' - (this, otherLines') = - case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of + classify = do + toks <- splitSpaces thisLine + case takeWhile (not . isPrefixOf "--") toks of (pattern:rest0) | Just (constr:rest) <- stripColonLast rest0 - , Just attrs <- mapM parseAttr rest -> - let (children, otherLines'') = parse (length spaces + 1) otherLines - children' = addAttrs attrs children - (pieces, check) = - case piecesFromStringCheck pattern of - (p, Nothing, c) -> (p, c) - -- FIXME: Give better error message - _ -> error "Invalid resource line: bad overlap" - in ((ResourceParent constr check pieces children' :), otherLines'') - (pattern:constr:rest) -> - let (pieces, mmulti, check) = piecesFromStringCheck pattern - (attrs, rest') = takeAttrs rest - disp = dispatchFromString rest' mmulti - in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines) - [] -> (id, otherLines) - _ -> error $ "Invalid resource line: " ++ thisLine + , Just attrs <- mapM parseAttr rest -> do + (children, otherLines'') <- parse (length spaces + 1) otherLines + let children' = addAttrs attrs children + (pieces, mmulti, check) <- piecesFromStringCheck pattern + case mmulti of + Nothing -> pure () + Just _ -> fail $ "Parent routes cannot have a multipiece: " ++ pattern + pure ((ResourceParent constr check (Set.fromList attrs) pieces children' :), otherLines'') + (pattern:constr:rest) -> do + (pieces, mmulti, check) <- piecesFromStringCheck pattern + let (attrs, rest') = takeAttrs rest + disp <- dispatchFromString rest' mmulti + pure ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines) + [] -> pure (id, otherLines) + _ -> fail $ "Invalid resource line: " ++ thisLine -- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive). -splitSpaces :: String -> [String] -splitSpaces "" = [] -splitSpaces str = - let (rest, piece) = parse $ dropWhile isSpace str in - piece:(splitSpaces rest) +splitSpaces :: MonadFail m => String -> m [String] +splitSpaces "" = pure [] +splitSpaces str = do + (rest, piece) <- parse $ dropWhile isSpace str + rest' <- splitSpaces rest + pure (piece : rest') where - parse :: String -> ( String, String) - parse ('{':s) = fmap ('{':) $ parseBracket s - parse (c:s) | isSpace c = (s, []) - parse (c:s) = fmap (c:) $ parse s - parse "" = ("", "") + parse ('{':s) = do (r, p) <- parseBracket s; pure (r, '{':p) + parse (c:s) | isSpace c = pure (s, []) + parse (c:s) = do (r, p) <- parse s; pure (r, c:p) + parse "" = pure ("", "") - parseBracket :: String -> ( String, String) - parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str - parseBracket ('}':s) = fmap ('}':) $ parse s - parseBracket (c:s) = fmap (c:) $ parseBracket s - parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str + parseBracket ('{':_) = fail $ "Invalid resource line (nested curly bracket): " ++ str + parseBracket ('}':s) = do (r, p) <- parse s; pure (r, '}':p) + parseBracket (c:s) = do (r, p) <- parseBracket s; pure (r, c:p) + parseBracket "" = fail $ "Invalid resource line (unclosed curly bracket): " ++ str -piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool) -piecesFromStringCheck s0 = - (pieces, mmulti, check) +piecesFromStringCheck :: MonadFail m => String -> m ([Piece String], Maybe String, Bool) +piecesFromStringCheck s0 = do + let (s1, check1) = stripBang s0 + (pieces', mmulti') <- piecesFromString $ drop1Slash s1 + let pieces = map snd pieces' + mmulti = fmap snd mmulti' + check = check1 && all fst pieces' && maybe True fst mmulti' + pure (pieces, mmulti, check) where - (s1, check1) = stripBang s0 - (pieces', mmulti') = piecesFromString $ drop1Slash s1 - pieces = map snd pieces' - mmulti = fmap snd mmulti' - check = check1 && all fst pieces' && maybe True fst mmulti' - stripBang ('!':rest) = (rest, False) stripBang x = (x, True) @@ -154,7 +157,7 @@ map goTree where goTree (ResourceLeaf res) = ResourceLeaf (goRes res) - goTree (ResourceParent w x y z) = ResourceParent w x y (map goTree z) + goTree (ResourceParent v w x y z) = ResourceParent v w x y (map goTree z) goRes res = res { resourceAttrs = noDupes ++ resourceAttrs res } @@ -181,36 +184,46 @@ go x y (('!':attr):rest) = go (x . (attr:)) y rest go x y (z:rest) = go x (y . (z:)) rest -dispatchFromString :: [String] -> Maybe String -> Dispatch String +dispatchFromString :: MonadFail m => [String] -> Maybe String -> m (Dispatch String) dispatchFromString rest mmulti - | null rest = Methods mmulti [] - | all (all isUpper) rest = Methods mmulti rest + | null rest = pure $ Methods mmulti [] + | all (all isUpper) rest = pure $ Methods mmulti rest dispatchFromString [subTyp, subFun] Nothing = - Subsite subTyp subFun + pure $ Subsite subTyp subFun dispatchFromString [_, _] Just{} = - error "Subsites cannot have a multipiece" -dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest + fail "Subsites cannot have a multipiece" +dispatchFromString rest _ = fail $ "Invalid list of methods: " ++ show rest drop1Slash :: String -> String drop1Slash ('/':x) = x drop1Slash x = x -piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String)) -piecesFromString "" = ([], Nothing) -piecesFromString x = +piecesFromString :: MonadFail m => String -> m ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String)) +piecesFromString "" = pure ([], Nothing) +piecesFromString x = do + rest <- piecesFromString $ drop 1 z + this <- pieceFromString y case (this, rest) of - (Left typ, ([], Nothing)) -> ([], Just typ) - (Left _, _) -> error "Multipiece must be last piece" - (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp) + (Left typ, ([], Nothing)) -> pure ([], Just typ) + (Left _, _) -> fail "Multipiece must be last piece" + (Right piece, (pieces, mtyp)) -> pure (piece:pieces, mtyp) where (y, z) = break (== '/') x - this = pieceFromString y - rest = piecesFromString $ drop 1 z parseType :: String -> Type parseType orig = maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig +-- | 'parseType' in 'MonadFail': a malformed type surfaces via 'fail' instead of +-- a raw 'error'. Used at the 'Language.Haskell.TH.Q' splice sites so a bad type +-- in a route definition becomes an attributed compile error. The pure +-- 'parseType' is retained for callers (e.g. tests) supplying known-good input. +-- +-- @since 1.7.0.0 +parseTypeM :: MonadFail m => String -> m Type +parseTypeM orig = + maybe (fail $ "Invalid type: " ++ show orig) (pure . ttToType) $ parseTypeTree orig + parseTypeTree :: String -> Maybe TypeTree parseTypeTree orig = toTypeTree pieces @@ -280,28 +293,41 @@ isTvar (h:_) = isLower h isTvar _ = False -pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) -pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x) -pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652 -pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x) +-- | 'MonadFail' so that an unclosed bracket in a 'Dynamic' piece (via +-- 'dropBracketM') surfaces as an attributed splice error rather than a raw +-- 'error' (the pure 'dropBracket' would otherwise bottom out deep in codegen). +pieceFromString :: MonadFail m => String -> m (Either (CheckOverlap, String) (CheckOverlap, Piece String)) +pieceFromString ('#':'!':x) = Right . (False,) . Dynamic <$> dropBracketM x +pieceFromString ('!':'#':x) = Right . (False,) . Dynamic <$> dropBracketM x -- https://github.com/yesodweb/yesod/issues/652 +pieceFromString ('#':x) = Right . (True,) . Dynamic <$> dropBracketM x -pieceFromString ('*':'!':x) = Left (False, x) -pieceFromString ('+':'!':x) = Left (False, x) +pieceFromString ('*':'!':x) = pure $ Left (False, x) +pieceFromString ('+':'!':x) = pure $ Left (False, x) -pieceFromString ('!':'*':x) = Left (False, x) -pieceFromString ('!':'+':x) = Left (False, x) +pieceFromString ('!':'*':x) = pure $ Left (False, x) +pieceFromString ('!':'+':x) = pure $ Left (False, x) -pieceFromString ('*':x) = Left (True, x) -pieceFromString ('+':x) = Left (True, x) +pieceFromString ('*':x) = pure $ Left (True, x) +pieceFromString ('+':x) = pure $ Left (True, x) -pieceFromString ('!':x) = Right $ (False, Static x) -pieceFromString x = Right $ (True, Static x) +pieceFromString ('!':x) = pure $ Right (False, Static x) +pieceFromString x = pure $ Right (True, Static x) dropBracket :: String -> String dropBracket str@('{':x) = case break (== '}') x of (s, "}") -> s _ -> error $ "Unclosed bracket ('{'): " ++ str dropBracket x = x + +-- | 'dropBracket' in 'MonadFail': an unclosed @{@ surfaces via 'fail' instead +-- of a raw 'error', so it becomes an attributed compile error at a splice site. +-- +-- @since 1.7.0.0 +dropBracketM :: MonadFail m => String -> m String +dropBracketM str@('{':x) = case break (== '}') x of + (s, "}") -> pure s + _ -> fail $ "Unclosed bracket ('{'): " ++ str +dropBracketM x = pure x -- | If this line ends with a backslash, concatenate it together with the next line. -- diff --git a/src/Yesod/Routes/TH.hs b/src/Yesod/Routes/TH.hs --- a/src/Yesod/Routes/TH.hs +++ b/src/Yesod/Routes/TH.hs @@ -1,11 +1,40 @@ module Yesod.Routes.TH ( module Yesod.Routes.TH.Types -- * Functions - , module Yesod.Routes.TH.RenderRoute + , -- ** RenderRoute + mkRenderRouteInstanceOpts + , mkRouteConsOpts + , shouldCreateResources + + , RouteOpts + , defaultOpts + , setEqDerived + , setShowDerived + , setReadDerived + , setFocusOnNestedRoute + , unsetFocusOnNestedRoute + , roFocusOnNestedRoute + , roNestedRouteFallthrough + , setCreateResources + , setParameterizedSubroute + , setNestedRouteFallthrough + , DiscoveryMode(..) + , discoveryMode , module Yesod.Routes.TH.ParseRoute , module Yesod.Routes.TH.RouteAttrs -- ** Dispatch - , module Yesod.Routes.TH.Dispatch + , MkDispatchSettings (..) + , mkDispatchClause + , defaultGetHandler + , SDC(..) + , mkDispatchInstance + , mkNestedDispatchInstance + , mkNestedDispatchInstanceWith + , NestedTarget (..) + , mkMDS + , mkYesodSubDispatch + , mkYesodSubDispatchWith + , subTopDispatch ) where import Yesod.Routes.TH.Types diff --git a/src/Yesod/Routes/TH/Dispatch.hs b/src/Yesod/Routes/TH/Dispatch.hs --- a/src/Yesod/Routes/TH/Dispatch.hs +++ b/src/Yesod/Routes/TH/Dispatch.hs @@ -1,213 +1,1054 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -module Yesod.Routes.TH.Dispatch - ( MkDispatchSettings (..) - , mkDispatchClause - , defaultGetHandler - ) where - -import Prelude hiding (exp) -import Language.Haskell.TH.Syntax -import Web.PathPieces -import Data.Maybe (catMaybes) -import Control.Monad (forM) -import Data.List (foldl') -import Control.Arrow (second) -import System.Random (randomRIO) -import Yesod.Routes.TH.Types -import Data.Char (toLower) - -data MkDispatchSettings b site c = MkDispatchSettings - { mdsRunHandler :: Q Exp - , mdsSubDispatcher :: Q Exp - , mdsGetPathInfo :: Q Exp - , mdsSetPathInfo :: Q Exp - , mdsMethod :: Q Exp - , mds404 :: Q Exp - , mds405 :: Q Exp - , mdsGetHandler :: Maybe String -> String -> Q Exp - , mdsUnwrapper :: Exp -> Q Exp - } - -data SDC = SDC - { clause404 :: Clause - , extraParams :: [Exp] - , extraCons :: [Exp] - , envExp :: Exp - , reqExp :: Exp - } - --- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on --- view patterns. --- --- Since 1.4.0 -mkDispatchClause :: MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause -mkDispatchClause MkDispatchSettings {..} resources = do - suffix <- qRunIO $ randomRIO (1000, 9999 :: Int) - envName <- newName $ "env" ++ show suffix - reqName <- newName $ "req" ++ show suffix - helperName <- newName $ "helper" ++ show suffix - - let envE = VarE envName - reqE = VarE reqName - helperE = VarE helperName - - clause404' <- mkClause404 envE reqE - getPathInfo <- mdsGetPathInfo - let pathInfo = getPathInfo `AppE` reqE - - let sdc = SDC - { clause404 = clause404' - , extraParams = [] - , extraCons = [] - , envExp = envE - , reqExp = reqE - } - clauses <- mapM (go sdc) resources - - return $ Clause - [VarP envName, VarP reqName] - (NormalB $ helperE `AppE` pathInfo) - [FunD helperName $ clauses ++ [clause404']] - where - handlePiece :: Piece a -> Q (Pat, Maybe Exp) - handlePiece (Static str) = return (LitP $ StringL str, Nothing) - handlePiece (Dynamic _) = do - x <- newName "dyn" - let pat = ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x]) - return (pat, Just $ VarE x) - - handlePieces :: [Piece a] -> Q ([Pat], [Exp]) - handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece - - mkCon :: String -> [Exp] -> Exp - mkCon name = foldl' AppE (ConE $ mkName name) - - mkPathPat :: Pat -> [Pat] -> Pat - mkPathPat final = - foldr addPat final - where - addPat x y = conPCompat '(:) [x, y] - - go :: SDC -> ResourceTree a -> Q Clause - go sdc (ResourceParent name _check pieces children) = do - (pats, dyns) <- handlePieces pieces - let sdc' = sdc - { extraParams = extraParams sdc ++ dyns - , extraCons = extraCons sdc ++ [mkCon name dyns] - } - childClauses <- mapM (go sdc') children - - restName <- newName "rest" - let restE = VarE restName - restP = VarP restName - - helperName <- newName $ "helper" ++ name - let helperE = VarE helperName - - return $ Clause - [mkPathPat restP pats] - (NormalB $ helperE `AppE` restE) - [FunD helperName $ childClauses ++ [clause404 sdc]] - go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do - (pats, dyns) <- handlePieces pieces - - (chooseMethod, finalPat) <- handleDispatch dispatch dyns - - return $ Clause - [mkPathPat finalPat pats] - (NormalB chooseMethod) - [] - where - handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat) - handleDispatch dispatch' dyns = - case dispatch' of - Methods multi methods -> do - (finalPat, mfinalE) <- - case multi of - Nothing -> return (conPCompat '[] [], Nothing) - Just _ -> do - multiName <- newName "multi" - let pat = ViewP (VarE 'fromPathMultiPiece) - (conPCompat 'Just [VarP multiName]) - return (pat, Just $ VarE multiName) - - let dynsMulti = - case mfinalE of - Nothing -> dyns - Just e -> dyns ++ [e] - route' = foldl' AppE (ConE (mkName name)) dynsMulti - route = foldr AppE route' extraCons - jroute = ConE 'Just `AppE` route - allDyns = extraParams ++ dynsMulti - mkRunExp mmethod = do - runHandlerE <- mdsRunHandler - handlerE' <- mdsGetHandler mmethod name - handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns - return $ runHandlerE - `AppE` handlerE - `AppE` envExp - `AppE` jroute - `AppE` reqExp - - func <- - case methods of - [] -> mkRunExp Nothing - _ -> do - getMethod <- mdsMethod - let methodE = getMethod `AppE` reqExp - matches <- forM methods $ \method -> do - exp <- mkRunExp (Just method) - return $ Match (LitP $ StringL method) (NormalB exp) [] - match405 <- do - runHandlerE <- mdsRunHandler - handlerE <- mds405 - let exp = runHandlerE - `AppE` handlerE - `AppE` envExp - `AppE` jroute - `AppE` reqExp - return $ Match WildP (NormalB exp) [] - return $ CaseE methodE $ matches ++ [match405] - - return (func, finalPat) - Subsite _ getSub -> do - restPath <- newName "restPath" - setPathInfoE <- mdsSetPathInfo - subDispatcherE <- mdsSubDispatcher - runHandlerE <- mdsRunHandler - sub <- newName "sub" - let allDyns = extraParams ++ dyns - sroute <- newName "sroute" - let sub2 = LamE [VarP sub] - (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns) - let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp - route' = foldl' AppE (ConE (mkName name)) dyns - route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons - exp = subDispatcherE - `AppE` runHandlerE - `AppE` sub2 - `AppE` route - `AppE` envExp - `AppE` reqExp' - return (exp, VarP restPath) - - mkClause404 envE reqE = do - handler <- mds404 - runHandler <- mdsRunHandler - let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE - return $ Clause [WildP] (NormalB exp) [] - -defaultGetHandler :: Maybe String -> String -> Q Exp -defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s -defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s - -conPCompat :: Name -> [Pat] -> Pat -conPCompat n pats = ConP n -#if MIN_VERSION_template_haskell(2,18,0) - [] -#endif - pats +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} + +module Yesod.Routes.TH.Dispatch + ( MkDispatchSettings (..) + , mkDispatchClause + , defaultGetHandler + , SDC(..) + , mkDispatchInstance + , mkNestedDispatchInstance + , mkNestedDispatchInstanceWith + , NestedTarget (..) + , SameSpliceNestedInstances (..) + , mkMDS + , mkYesodSubDispatch + , mkYesodSubDispatchWith + , mkYesodSubDispatchWithDelegate + , subTopDispatch + , parseYesodName + ) where + +import Text.Parsec (parse, many1, many, eof, try, option, sepBy1) +import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char) +import Data.Maybe +import Data.Proxy (Proxy(..)) +import Yesod.Routes.TH.RenderRoute +import qualified Network.Wai as W +import Yesod.Core.Content (ToTypedContent (..)) +import Language.Haskell.TH hiding (cxt, instanceD) +import Yesod.Core.Types hiding (Body) +import Yesod.Core.Class.Dispatch +import Prelude hiding (exp) +import Yesod.Routes.TH.Internal +import Control.Monad +import Control.Monad.Reader (ReaderT, runReaderT, asks, local, lift) +import Data.List (foldl') +import Yesod.Routes.TH.Types +import Data.Char (toLower) +import Yesod.Core.Internal.Run +import Yesod.Core.Handler +import Yesod.Core.Class.Dispatch.ToParentRoute (ToParentRoute(..)) +import Yesod.Core.Class.Yesod (Yesod) + +-- | This datatype describes how to create the dispatch clause for a route +-- path. +data MkDispatchSettings b site c = MkDispatchSettings + { mdsRunHandler :: Q Exp + , mdsSubDispatcher :: Q Exp + , mdsGetPathInfo :: Q Exp + , mdsSetPathInfo :: Q Exp + , mdsMethod :: Q Exp + , mds404 :: Q Exp + , mds405 :: Q Exp + , mdsGetHandler :: Maybe String -> String -> Q Exp + , mdsUnwrapper :: Exp -> Q Exp + , mdsNestedRouteFallthrough :: !Bool + -- ^ When 'True', fall through if no route matches (except in the final + -- case). When 'False', return 404 if the current route clause fails to + -- match. + -- + -- @since 1.7.0.0 + , mdsNestedTarget :: NestedTarget + -- ^ Whether this dispatch is for a top-level site or a subsite. Selects the + -- nested-dispatch class to probe ('nestedTargetClass') and the + -- nested-dispatch function to delegate to ('nestedTargetFn'): + -- 'TopLevelNested' uses @YesodDispatchNested@\/@yesodDispatchNested@, + -- 'SubsiteNested' uses @YesodSubDispatchNested@\/@yesodSubDispatchNested@. + -- + -- @since 1.7.0.0 + , mdsSameSpliceNestedInstances :: !SameSpliceNestedInstances + -- ^ Whether the caller emits the matching per-parent nested-dispatch + -- instances in the same splice as this flat dispatch body; see + -- 'SameSpliceNestedInstances' for how this affects a parent clause. + -- 'mkMDS' defaults to 'NoSameSpliceNestedInstances'. + -- + -- @since 1.7.0.0 + } + +data SDC = SDC + { extraParams :: [Exp] + , extraCons :: [Exp] + , envExp :: Exp + , reqExp :: Exp + } + +-- | Which phase of clause generation we're in, which is the only thing that +-- decides how a matched result is wrapped (see 'wrapForPhase'). At the top level +-- the dispatch result is returned unwrapped; inside a parent's inline children +-- we generate helper clauses whose enclosing parent must tell a match from a +-- fall-through miss, so the result is wrapped in 'Just'. Generation starts at +-- 'TopLevelPhase' and flips to 'NestedPhase' on the first descent (and never +-- back), so the two phases are a single 'local'. +data DispatchPhase = TopLevelPhase | NestedPhase + +-- | How a matched result is wrapped in a given phase. See 'DispatchPhase'. +wrapForPhase :: DispatchPhase -> Exp -> Exp +wrapForPhase TopLevelPhase = id +wrapForPhase NestedPhase = \e -> ConE 'Just `AppE` e + +-- | The reader environment threaded through 'mkDispatchClause's clause +-- generator. 'envSdc' is the accumulated dispatch context (extended via 'local' +-- as we descend into a parent's children); 'envPhase' selects how a matched +-- result is wrapped. +data Env = Env + { envSdc :: SDC + , envPhase :: DispatchPhase + } + +-- | The monad 'mkDispatchClause's clause generator runs in: 'Q' carrying an +-- 'Env' read through 'MonadReader'. Every helper that needs the dispatch +-- context or the result wrapper takes them from the environment ('asks' / +-- 'local') rather than as arguments; 'liftQ' lifts the concrete-'Q' primitives. +type DispatchM = ReaderT Env Q + +-- | Whether nested-route dispatch is being generated for a top-level site or +-- for a subsite. This is the single bit that selects the whole top-vs-subsite +-- plumbing: the dispatch class to probe and the function to delegate to (used +-- by 'MkDispatchSettings' via 'mdsNestedTarget'), and the runner function, +-- dispatch function\/class, and subsite-environment construction used when +-- generating nested-dispatch instances. All of those follow from this enum via +-- the @nestedTarget*@ derivation functions below. +-- +-- @since 1.7.0.0 +data NestedTarget + = TopLevelNested + -- ^ A top-level site: @YesodDispatchNested@\/@yesodDispatchNested@, run via + -- @yesodRunner@, constructing 'YesodSubRunnerEnv' directly. + | SubsiteNested + -- ^ A subsite: @YesodSubDispatchNested@\/@yesodSubDispatchNested@, run via + -- @subHelper@, composing through the outer 'YesodSubRunnerEnv' (like + -- 'subTopDispatch'). + deriving (Eq, Show) + +-- | Whether the splice emitting a flat dispatch body also generates the +-- matching per-parent nested-dispatch instances (@YesodDispatchNested@ \/ +-- @YesodSubDispatchNested@) in the same declaration group. +-- +-- @since 1.7.0.0 +data SameSpliceNestedInstances + = GeneratesNestedInstances + -- ^ The caller emits the per-parent nested instances alongside the flat + -- dispatch, so a parent clause /delegates/ to its instance even though the + -- instance does not exist at probe time — GHC resolves it once the whole + -- declaration group is spliced. This avoids inlining each nested leaf's + -- dispatch into the flat body /and/ re-emitting it in the per-parent + -- instance (see 'mkTopLevelDispatchInstance'). + | NoSameSpliceNestedInstances + -- ^ Only the flat dispatch is emitted. A parent delegates only when its + -- nested instance already exists (the cross-module split case) and inlines + -- otherwise — required for standalone entry points like + -- 'mkYesodSubDispatch', where delegating would reference a missing + -- instance. + deriving (Eq, Show) + +-- | The nested-dispatch class to probe\/emit for a target: +-- @''YesodDispatchNested@ for top-level, @''YesodSubDispatchNested@ for subsites. +nestedTargetClass :: NestedTarget -> Name +nestedTargetClass TopLevelNested = ''YesodDispatchNested +nestedTargetClass SubsiteNested = ''YesodSubDispatchNested + +-- | The nested-dispatch function to delegate to\/emit for a target: +-- @'yesodDispatchNested@ for top-level, @'yesodSubDispatchNested@ for subsites. +nestedTargetFn :: NestedTarget -> Name +nestedTargetFn TopLevelNested = 'yesodDispatchNested +nestedTargetFn SubsiteNested = 'yesodSubDispatchNested + +-- | The runner function used inside generated nested-dispatch clauses: +-- @'yesodRunner@ for top-level, @'subHelper@ for subsites. +nestedTargetRunner :: NestedTarget -> Name +nestedTargetRunner TopLevelNested = 'yesodRunner +nestedTargetRunner SubsiteNested = 'subHelper + +-- | The 'ArityCallSite' for arity-mismatch error messages: a top-level site is +-- reached through @mkYesod@, a subsite through @mkYesodSubDispatchInstance@. +nestedTargetCallSite :: NestedTarget -> ArityCallSite +nestedTargetCallSite TopLevelNested = TopLevelCall +nestedTargetCallSite SubsiteNested = SubsiteCall + +-- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on +-- view patterns. +-- +-- The function returns the dispatch 'Clause' along with a @['String']@ of the +-- names of nested route types that require a delegation instance to be +-- generated. For 'YesodDispatch', those are 'YesodDispatchNested' instances; for +-- the subsite case, 'YesodSubDispatchNested'. +-- +-- @since 1.7.0.0 — the leading @[Name]@\/@[Exp]@ parameters were dropped and the +-- result type changed from @Clause@ to @Q ([String], Clause)@. +mkDispatchClause :: forall a b site c. TyArgs -> MkDispatchSettings b site c -> [ResourceTree a] -> Q ([String], Clause) +mkDispatchClause tyargs MkDispatchSettings {..} resources = do + envName <- newName "env" + reqName <- newName "req" + helperName <- newName "dispatchHelper" + + let envE = VarE envName + reqE = VarE reqName + helperE = VarE helperName + + clause404' <- mkClause404 envE reqE + getPathInfo <- mdsGetPathInfo + let pathInfo = getPathInfo `AppE` reqE + + let sdc = SDC + { extraParams = [] + , extraCons = [] + , envExp = envE + , reqExp = reqE + } + -- Generate the dispatch clauses. 'go' runs in @'ReaderT' 'Env' Q@: the + -- top-level call starts at @envPhase = TopLevelPhase@ so the top-level + -- resources produce the final (unwrapped) dispatch result and report which + -- parents need a nested-dispatch instance generated. Descending into a + -- parent's inline children flips @envPhase@ to 'NestedPhase' (via 'local'), + -- so children are 'Just'-wrapped helper clauses the enclosing parent can + -- fall through on; their reported names are dropped (only top-level parents + -- matter). + let topEnv = Env { envSdc = sdc, envPhase = TopLevelPhase } + (childNames, clauses) <- mconcat <$> runReaderT (mapM go resources) topEnv + + pure + ( childNames + , Clause + [VarP envName, VarP reqName] + (NormalB $ helperE `AppE` pathInfo) + [FunD helperName $ clauses ++ [clause404']] + ) + where + -- Lift a concrete-'Q' action (the TH primitives and this package's own + -- @Q@-typed helpers) into 'DispatchM'. + liftQ :: Q x -> DispatchM x + liftQ = lift + + -- The current phase's result wrapper (see 'wrapForPhase'). + askWrap :: DispatchM (Exp -> Exp) + askWrap = asks (wrapForPhase . envPhase) + + -- Run an action in the scope of a parent's inline children: extend the + -- accumulated dynamics and parent constructors with this parent's, and flip + -- to 'NestedPhase'. This single 'local' — entered once at the top→nested + -- boundary and never undone — is the entire top-vs-nested phase distinction. + withChildScope :: [Exp] -> Exp -> DispatchM r -> DispatchM r + withChildScope dyns constr = local $ \e -> + let sdc = envSdc e + in e { envSdc = sdc + { extraParams = extraParams sdc ++ dyns + , extraCons = extraCons sdc ++ [constr] + } + , envPhase = NestedPhase + } + + -- | Generate the dispatch clauses for a resource tree node, plus the + -- @['String']@ of parents that need a nested-dispatch instance generated. + -- Names are reported for every parent here, but only the top-level call + -- keeps them; the parent arm drops its children's names (the deeper + -- instances are generated by a separate recursion in + -- 'mkNestedDispatchInstanceWith'). + go :: ResourceTree a -> DispatchM ([String], [Clause]) + go (ResourceParent name _check _attrs pieces children) = do + -- Delegate to the child's nested-dispatch instance when one already + -- exists (the configured class: YesodDispatchNested for top-level, + -- YesodSubDispatchNested for subsites). This is what makes splitting + -- a parent's nested routes across modules work. When no such instance + -- exists — the ordinary single-module case — the check fails and we + -- inline the children below, so this stays backwards compatible. + -- 'nestedInstanceExists' is the shared probe: it resolves the name once + -- and saturates by the child's own reified arity, so it never aborts + -- the splice (see its haddock). + instanceExists <- + liftQ (nestedInstanceExists (nestedTargetClass mdsNestedTarget) =<< resolveRouteCon name) + + -- Delegate to the nested-dispatch instance either when one already + -- exists (cross-module split) or when the caller will generate it in + -- this same splice ('mdsSameSpliceNestedInstances'). In the latter case + -- the instance does not exist at probe time, but GHC resolves it after + -- the whole declaration group is spliced — so we avoid inlining every + -- nested leaf's dispatch logic here only to re-emit it in the parent's + -- 'YesodDispatchNested' instance. We still report the name below so that + -- instance actually gets generated. + let delegate = + instanceExists || mdsSameSpliceNestedInstances == GeneratesNestedInstances + + (pats, dyns) <- liftQ $ handlePiecesM pieces + restName <- liftQ $ newName "_rest" + helperName <- liftQ $ newName ("helper" ++ name) + let helperCall = VarE helperName `AppE` VarE restName + constr = applyConPieces name dyns + + helperClauses <- + if delegate + then do + expr <- delegateToNestedInstance name dyns + pure [Clause [VarP restName] (NormalB expr) []] + else do + -- Inline dispatch: descend into the children with the + -- extended scope and 'Just' wrapping; their reported names + -- are dropped (only top-level parents matter). + childClauses <- + concatMap snd <$> withChildScope dyns constr (mapM go children) + pure $ childClauses ++ [Clause [WildP] (NormalB (ConE 'Nothing)) []] + + body <- parentBody helperCall + + -- Report this parent as needing a nested-dispatch instance whenever one + -- does not already exist — both when we inlined and when we delegated to + -- a yet-to-be-generated same-splice instance + -- ('mdsSameSpliceNestedInstances'). + -- Whether the caller acts on this (i.e. actually generates the instance) + -- is the caller's decision — see 'mkDispatchInstance'. + pure + ( [name | not instanceExists] + , [ Clause + [mkPathPat (EndRest restName) pats] + body + [FunD helperName helperClauses] ] + ) + + go (ResourceLeaf (Resource name pieces dispatch _ _check)) = do + (pats, dyns) <- liftQ $ handlePiecesM pieces + (chooseMethod, finalPat) <- handleDispatch name dispatch dyns + wrap <- askWrap + let clauseBody = NormalB (wrap chooseMethod) + pure ([], [Clause [mkPathPat finalPat pats] clauseBody []]) + + -- | Delegate body for a parent that already has a nested-dispatch instance: + -- call the configured nested-dispatch function, passing this route's + -- dynamics — plus the accumulated parent dynamics from the environment — as + -- ParentArgs. + delegateToNestedInstance :: String -> [Exp] -> DispatchM Exp + delegateToNestedInstance name dyns = do + sdc <- asks envSdc + let thisRouteParentArgs = extraParams sdc ++ dyns + liftQ (nestedDispatchCall (nestedTargetFn mdsNestedTarget) name dyns tyargs sdc thisRouteParentArgs) + + -- | The body of a parent dispatch clause. @helperCall@ runs the parent's + -- inline helper on the remaining path; per the fallthrough flag we either + -- fall through on a 'Nothing' (pattern guard) or commit to a 404. The + -- matched result is run through the current phase's wrapper. + parentBody :: Exp -> DispatchM Body + parentBody helperCall = do + wrap <- askWrap + if mdsNestedRouteFallthrough + then liftQ $ mkGuardedBody helperCall (\match' -> pure (wrap (VarE match'))) + else do + sdc <- asks envSdc + liftQ $ do + matchName <- newName "match" + baseNotFoundExp <- + [| $(mdsRunHandler) $(mds404) $(pure (envExp sdc)) Nothing $(pure (reqExp sdc)) |] + pure $ NormalB $ CaseE helperCall + [ Match (conPCompat 'Just [VarP matchName]) (NormalB (wrap (VarE matchName))) [] + , Match (conPCompat 'Nothing []) (NormalB (wrap baseNotFoundExp)) [] + ] + + -- | Build the chosen-method expression and final path tail for a leaf, + -- reading the dispatch context ('extraParams' / 'extraCons' / 'envExp' / + -- 'reqExp') from the environment. + handleDispatch :: String -> Dispatch a -> [Exp] -> DispatchM (Exp, PathTail) + handleDispatch name dispatch' dyns = do + SDC {..} <- asks envSdc + liftQ $ case dispatch' of + Methods multi methods -> do + (finalPat, mfinalE) <- + case multi of + Nothing -> return (EndExact, Nothing) + Just _ -> do + multiName <- newName "multi" + return (EndMulti multiName, Just $ VarE multiName) + + let dynsMulti = + case mfinalE of + Nothing -> dyns + Just e -> dyns ++ [e] + thisRoute = applyConPieces name dynsMulti + fullRoute = foldr AppE thisRoute extraCons + jroute = ConE 'Just `AppE` fullRoute + allDyns = extraParams ++ dynsMulti + mkRunExp mmethod = do + runHandlerE <- mdsRunHandler + handlerE' <- mdsGetHandler mmethod name + handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns + return $ runHandlerE + `AppE` handlerE + `AppE` envExp + `AppE` jroute + `AppE` reqExp + + func <- + case methods of + [] -> mkRunExp Nothing + _ -> do + getMethod <- mdsMethod + let methodE = getMethod `AppE` reqExp + matches <- forM methods $ \method -> do + exp <- mkRunExp (Just method) + return $ Match (LitP $ StringL method) (NormalB exp) [] + match405 <- do + runHandlerE <- mdsRunHandler + handlerE <- mds405 + let exp = runHandlerE + `AppE` handlerE + `AppE` envExp + `AppE` jroute + `AppE` reqExp + return $ Match WildP (NormalB exp) [] + return $ CaseE methodE $ matches ++ [match405] + + return (func, finalPat) + + Subsite _ getSub -> do + restPath <- newName "restPath" + let allDyns = extraParams ++ dyns + sub2 <- mkLambda "sub" $ \sub -> + pure $ foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns + routeBuilder <- mkLambda "sroute" $ \sroute -> + pure $ let thisRoute = applyConPieces name dyns + in foldr AppE (AppE thisRoute $ VarE sroute) extraCons + exp <- + [| $(mdsSubDispatcher) + $(mdsRunHandler) + $(pure sub2) + $(pure routeBuilder) + $(pure envExp) + ($(mdsSetPathInfo) $(varE restPath) $(pure reqExp)) |] + return (exp, EndRest restPath) + + -- The dispatch helper produced by 'mkDispatchClause' is always a terminal + -- authority (the top-level / subsite entry point), so a final miss commits + -- to a 404 here. Inline nested helpers built by 'go' under 'withChildScope' + -- bake their own @Nothing@ fallback at their call site instead. + mkClause404 envE reqE = do + exp <- [| $(mdsRunHandler) $(mds404) $(pure envE) Nothing $(pure reqE) |] + return $ Clause [WildP] (NormalB exp) [] + +-- | This function generates code to call the nested dispatch function +-- (either 'yesodDispatchNested' or 'yesodSubDispatchNested'). +nestedDispatchCall + :: Name + -- ^ The dispatch function to call (e.g. 'yesodDispatchNested' or 'yesodSubDispatchNested') + -> String + -- ^ The name of the nested route (e.g., "FirstFooR") + -> [Exp] + -- ^ The dynamic arguments for this route constructor + -> TyArgs + -- ^ Type arguments for parameterized routes + -> SDC + -- ^ The accumulated 'SDC'. + -> [Exp] + -- ^ The parent dynamic bound variables (for passing as ParentArgs). + -> Q Exp +nestedDispatchCall dispatchFn routeName routeDyns tyargs sdc parentDyns = do + routeType <- appliedRouteTypeNamed routeName tyargs + let wrapper = foldr composeE (applyConPieces routeName routeDyns) (extraCons sdc) + [| $(varE dispatchFn) + (Proxy :: Proxy $(pure routeType)) + $(pure $ parentArgsExprFromExps parentDyns) + $(pure wrapper) + $(pure $ envExp sdc) + $(pure $ reqExp sdc) + |] + +-- | Given an 'Exp' which should result in a @'Maybe' a@, does: +-- +-- @ +-- | Just a <- exp = mkRhs a +-- @ +-- +mkGuardedBody + :: Exp + -- ^ The expression to match Just with + -> (Name -> Q Exp) + -- ^ The function to take a 'Name' and create the right hand value on + -- successful match. + -> Q Body +mkGuardedBody exp mkRhs = do + matchName <- newName "match" + result <- mkRhs matchName + let patGuard = + PatG [BindS (conPCompat 'Just [VarP matchName]) exp] + pure $ GuardedB [(patGuard, result)] + +defaultGetHandler :: Maybe String -> String -> Q Exp +defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s +defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s + +-- | If the generation of @'YesodDispatch'@ instance require finer +-- control of the types, contexts etc. using this combinator. You will +-- hardly need this generality. However, in certain situations, like +-- when writing library/plugin for yesod, this combinator becomes +-- handy. +mkDispatchInstance + :: RouteOpts + -> Type + -- ^ The master site type + -> Cxt + -- ^ Context of the instance + -> TyArgs + -- ^ type arguments to constructors + -> (Exp -> Q Exp) + -- ^ Unwrap handler + -> [ResourceTree Type] + -- ^ The resource + -> DecsQ +mkDispatchInstance routeOpts master cxt tyargs unwrapper res = + -- Branch on the focus target via the accessor rather than a constructor + -- pattern, so 'RouteOpts' can stay abstract (its constructor is not + -- exported). 'Just target' focuses a single nested route for + -- module-splitting; 'Nothing' generates the full top-level instance. + case roFocusOnNestedRoute routeOpts of + Just target -> + mkNestedDispatchInstance routeOpts target master cxt tyargs unwrapper res + Nothing -> + mkTopLevelDispatchInstance routeOpts master cxt tyargs unwrapper res + +mkTopLevelDispatchInstance + :: RouteOpts + -> Type + -> Cxt + -> TyArgs + -> (Exp -> Q Exp) + -> [ResourceTree Type] + -> DecsQ +mkTopLevelDispatchInstance routeOpts master cxt tyargs unwrapper res = do + let mds = + mkMDS + unwrapper + [|yesodRunner|] + [|\parentRunner getSub toParent env -> yesodSubDispatch + YesodSubRunnerEnv + { ysreParentRunner = parentRunner + , ysreGetSub = getSub + , ysreToParentRoute = toParent + , ysreParentEnv = env + } + |] + -- Under nested discovery this instance also emits a + -- 'YesodDispatchNested' instance per top-level parent (see + -- 'childNamesToGenerate'). When it does, the flat @yesodDispatch@ clause + -- can /delegate/ each parent to that same-splice instance rather than + -- inlining the whole subtree's dispatch logic (which the nested instance + -- would then re-emit). Under 'InlineCompat' no nested instances are + -- generated, so the flat clause must inline as before. + usesNestedDiscovery = + case discoveryMode routeOpts tyargs of + NestedDiscovery -> True + InlineCompat -> False + mdsWithNestedDispatch = mds + { mdsNestedRouteFallthrough = roNestedRouteFallthrough routeOpts + , mdsSameSpliceNestedInstances = + if usesNestedDiscovery + then GeneratesNestedInstances + else NoSameSpliceNestedInstances + } + (childNames, clause') <- mkDispatchClause tyargs mdsWithNestedDispatch res + let thisDispatch = FunD 'yesodDispatch [clause'] + -- Only generate 'YesodDispatchNested' instances for children when this + -- site uses nested discovery. A parameterized site that has not opted + -- in keeps unparameterized subroute datatypes (see 'discoveryMode' in + -- RenderRoute), so generating nested instances — which would reference + -- the parameterized form — must be suppressed to stay consistent. + childNamesToGenerate = + if usesNestedDiscovery then childNames else [] + childInstances <- + fmap mconcat $ forM childNamesToGenerate $ \name -> do + mkNestedDispatchInstance routeOpts name master cxt tyargs unwrapper res + return (instanceD cxt yDispatch [thisDispatch] : childInstances) + where + yDispatch = ConT ''YesodDispatch `AppT` master + +-- | Generate the top-level @YesodDispatchNested@ instance (and the +-- @UrlToDispatch@\/@RedirectUrl@ instances for fragments with no dynamic parent +-- pieces) for a nested route target. A thin wrapper over +-- 'mkNestedDispatchInstanceWith' with the top-level config and the master site. +-- +-- @since 1.7.0.0 +mkNestedDispatchInstance + :: RouteOpts + -> String + -> Type + -> Cxt + -> TyArgs -- ^ tyargs + -> (Exp -> Q Exp) + -> [ResourceTree Type] + -> Q [Dec] +mkNestedDispatchInstance routeOpts target master cxt tyargs unwrapper res = + mkNestedDispatchInstanceWith TopLevelNested (Just master) + routeOpts target cxt tyargs unwrapper res + +-- | The shared body of the top-level ('mkNestedDispatchInstance') and subsite +-- (@mkNestedSubDispatchInstance@, in "Yesod.Core.Internal.TH") nested-dispatch +-- instance generators. Both +-- find the target, build the parent-dynamics pattern, generate the dispatch +-- clauses via 'genNestedDispatchClauses', emit one +-- 'nestedTargetClass'\/'nestedTargetFn' instance, and recurse into nested +-- children. They differ only in the 'NestedTarget' (which selects the +-- dispatch function\/class, runner, and subsite-env construction) and whether a +-- master site is in play: a @'Just' master@ marks the top-level case and additionally emits +-- the @UrlToDispatch@\/@RedirectUrl@ instances, which the subsite case +-- ('Nothing') never produces. +mkNestedDispatchInstanceWith + :: NestedTarget + -> Maybe Type -- ^ @Just master@ ⇒ top-level (also emit UrlToDispatch\/RedirectUrl); @Nothing@ ⇒ subsite + -> RouteOpts + -> String + -> Cxt + -> TyArgs + -> (Exp -> Q Exp) + -> [ResourceTree Type] + -> Q [Dec] +mkNestedDispatchInstanceWith nestedTarget mmaster routeOpts target cxt tyargs unwrapper res = do + -- Resolve the target subtree from the root exactly once. The recursion into + -- nested children below threads the already-resolved @(prePieces, subres)@ + -- straight through ('go'), rather than re-passing the full root and walking + -- it from scratch for every descendant (which was O(nodes × depth)). + case findNestedRoute target res of + Nothing -> + fail $ "Target '" ++ target ++ "' was not found in resources." + Just (prePieces, subres) -> + go target prePieces subres + where + go curTarget prePieces subres = do + -- The parent's static depth and how many dynamic pieces it consumes (only + -- the count matters below, for the parent-dynamics pattern and the + -- no-dynamics UrlToDispatch case). + let parentDepth = length prePieces + preDyns = [() | Dynamic _ <- prePieces] + targetT = applyTyArgs (ConT (mkName curTarget)) tyargs + + -- UrlToDispatch/RedirectUrl is a top-level-only convenience and only + -- possible when ParentArgs ~ () (no dynamic parent pieces). + urlToDispatchInstances <- case (mmaster, preDyns) of + (Just master, []) -> + mkUrlToDispatchRedirectInstances cxt curTarget targetT master + _ -> + pure [] + + -- Generate the parent dynamic argument variables once, and derive the + -- binding pattern from them. The clause-generator is handed the @['Name']@ + -- directly (it used to re-decode them out of the pattern). + parentDynVars <- forM preDyns $ \_ -> newName "parentDyn" + let parentDynsP = parentArgsPat parentDynVars + + -- Generate names for the instance parameters + toParentN <- newName "toParentRoute" + envN <- newName "env" + reqN <- newName "req" + + -- Generate dispatch clauses for each child resource + clauses <- genNestedDispatchClauses + nestedTarget + routeOpts + parentDynVars + (VarE toParentN) + (VarE envN) + (VarE reqN) + unwrapper + tyargs + subres + + dropExp <- [| drop parentDepth (W.pathInfo $(varE reqN)) |] + let dispatchNestedT = ConT (nestedTargetClass nestedTarget) `AppT` targetT + thisDispatch = FunD (nestedTargetFn nestedTarget) + [Clause + [WildP, parentDynsP, VarP toParentN, VarP envN, VarP reqN] + (NormalB $ CaseE dropExp clauses) + [] + ] + + childInstances <- + fmap mconcat $ forM subres $ \childRes -> do + case childRes of + ResourceParent name _ _ childPieces grandchildren -> do + rc <- resolveRouteCon name + instanceExists <- nestedInstanceExists (nestedTargetClass nestedTarget) rc + if instanceExists + then pure [] + else do + -- Run the same arity guard the top-level + -- 'mkYesodSubDispatchInstance' applies, so a + -- 2nd-level-or-deeper nested datatype whose + -- parameter count doesn't match the (sub)site's + -- type arguments fails with the actionable message + -- rather than a cryptic kind error from generated + -- code. A no-op for the monomorphic (0-arity) case. + assertNestedSubArity + (nestedTargetCallSite nestedTarget) + (SubsiteName curTarget) + (SubsiteArity (tyArgsArity tyargs)) + rc + -- Recurse on the already-resolved subtree: this + -- child's accumulated prefix is the parent's plus + -- this child's own pieces. + go name (prePieces <> childPieces) grandchildren + _ -> pure [] + + return + ( instanceD cxt dispatchNestedT + [ thisDispatch + ] + : childInstances <> urlToDispatchInstances + ) + +-- | The top-level-only @UrlToDispatch@ + @RedirectUrl@ instances for a nested +-- route fragment whose @ParentArgs ~ ()@ (no dynamic parent pieces), letting +-- the fragment's constructor be used directly in @setUrl@\/@redirect@ without +-- the @WithParentArgs@ wrapper. Subsite nested dispatch emits none of these. +mkUrlToDispatchRedirectInstances + :: Cxt + -> String -- ^ target route name (for the in-scope ToParentRoute check) + -> Type -- ^ the applied target route type + -> Type -- ^ the master site type + -> Q [Dec] +mkUrlToDispatchRedirectInstances cxt target targetT master = do + urlToDispatchT <- [t| UrlToDispatch $(pure targetT) $(pure master) |] + urlToDispatchFn <- [e| toWaiAppYreNested (Proxy :: Proxy $(pure targetT)) () |] + mYesodConstraint <- do + hasYesodInstance <- isInstance ''Yesod [master] + if hasYesodInstance + then pure [] + else do + yesodContext <- [t| Yesod $(pure master) |] + pure [yesodContext] + mToParentRouteConstraint <- do + mtypeName <- lookupTypeName target + parentRouteCxt <- [t| ToParentRoute $(pure targetT) |] + case mtypeName of + Nothing -> do + -- must be generating it still. assume we don't + -- have the instance in scope. + pure [parentRouteCxt] + Just _ -> do + -- type is around, let's make sure it's not + -- redundant? + hasToParentRouteInstance <- isInstance ''ToParentRoute [targetT] + if hasToParentRouteInstance + then pure [] + else do + pure [parentRouteCxt] + redirectT <- [t| RedirectUrl $(pure master) $(pure targetT) |] + redirectUrlFn <- [e| toTextUrl . WithParentArgs () |] + pure + [ instanceD (cxt <> mYesodConstraint <> mToParentRouteConstraint) urlToDispatchT + [ FunD 'urlToDispatch + [ Clause [ WildP ] (NormalB urlToDispatchFn) [] + ] + ] + -- OVERLAPPABLE so a strictly more specific hand-written instance (e.g. + -- one carrying type variables, as for a parameterized site) takes + -- precedence over this generated convenience instance. Note that a + -- hand-written instance with an identical fully-concrete head still + -- collides as a duplicate, regardless of this pragma. + , InstanceD (Just Overlappable) (cxt <> mToParentRouteConstraint) redirectT + [ FunD 'toTextUrl + [ Clause [ ] (NormalB redirectUrlFn) [] ] + ] + ] + + +-- | Generate dispatch clauses for nested dispatch instances. +-- Parameterized by 'NestedTarget' to support both +-- 'YesodDispatchNested' (top-level) and 'YesodSubDispatchNested' (subsite). +genNestedDispatchClauses + :: NestedTarget + -> RouteOpts + -> [Name] -- ^ parent dynamic arg variables + -> Exp -- ^ toParentRoute expression + -> Exp -- ^ yre expression (YesodRunnerEnv or YesodSubRunnerEnv) + -> Exp -- ^ req expression + -> (Exp -> Q Exp) -- ^ unwrapper + -> TyArgs -- ^ type arguments for parameterized routes + -> [ResourceTree Type] + -> Q [Match] +genNestedDispatchClauses nestedTarget routeOpts parentDynVars toParentE yreE reqE unwrapper tyargs resources = do + resourceClauses <- traverse genClauseForResource resources + + -- Terminal-miss clause: a nested dispatch instance ALWAYS returns 'Nothing' + -- when no clause matches the remaining path, regardless of this module's + -- fallthrough flag. 'yesodDispatchNested'/'yesodSubDispatchNested' are + -- documented to return 'Nothing' on a miss so that the *caller* (the + -- delegating parent clause, or the top-level/subsite terminal authority) + -- decides whether the miss commits to a 404 or falls through to a sibling. + -- Baking a 404 in here when fallthrough is disabled would let a split-out + -- child silently override a fallthrough-wanting parent compiled in another + -- module. The commit semantics of @fallthrough = False@ instead live at the + -- delegating clauses (the 'ResourceParent' arm below and the inline parent + -- body in 'mkDispatchClause') and at the terminal authorities. + let fallbackClause = Match WildP (NormalB (ConE 'Nothing)) [] + + return $ concat resourceClauses ++ [fallbackClause] + where + genClauseForResource :: ResourceTree Type -> Q [Match] + genClauseForResource (ResourceLeaf (Resource name pieces dispatch _ _check)) = do + (pats, dynVars) <- handlePiecesNames pieces + let routeCon = applyConPieces name (map VarE dynVars) + allDynVars = parentDynVars ++ dynVars + + case dispatch of + Methods mmulti methods -> do + -- Mirror the inline path (see 'handleDispatch' in + -- 'mkDispatchClause'): a trailing multipiece binds a fresh + -- @multi@ via 'EndMulti', and that value must be appended both + -- to the route constructor's arguments and to the handler's + -- arguments. Hardcoding 'EndExact' here would 404 any non-empty + -- tail and build the constructor one argument short. + (finalPat, mMultiE) <- case mmulti of + Nothing -> pure (EndExact, Nothing) + Just _ -> do + multiName <- newName "multi" + pure (EndMulti multiName, Just (VarE multiName)) + let dynExpsMulti = case mMultiE of + Nothing -> map VarE dynVars + Just e -> map VarE dynVars ++ [e] + routeExp = toParentE `AppE` applyConPieces name dynExpsMulti + allDynExps = map VarE parentDynVars ++ dynExpsMulti + handlerExp <- genHandlerCase name methods allDynExps + body <- + [| Just ($(varE (nestedTargetRunner nestedTarget)) + $(pure handlerExp) + $(pure yreE) + (Just $(pure routeExp)) + $(pure reqE)) |] + return [Match (mkPathPat finalPat pats) (NormalB body) []] + + Subsite _ getSub -> do + restPath <- newName "restPath" + sub2 <- mkLambda "sub" $ \sub -> + pure $ foldl' AppE (VarE (mkName getSub) `AppE` VarE sub) (map VarE allDynVars) + routeLam <- mkLambda "sroute" $ \srouteN -> + [e| $(pure toParentE) ( $(pure routeCon) $(varE srouteN)) |] + let reqExp' = RecUpdE reqE [('W.pathInfo, VarE restPath)] + body <- case nestedTarget of + TopLevelNested -> + -- Top-level: construct YesodSubRunnerEnv directly + [| Just (yesodSubDispatch + YesodSubRunnerEnv + { ysreParentRunner = yesodRunner + , ysreGetSub = $(pure sub2) + , ysreToParentRoute = $(pure routeLam) + , ysreParentEnv = $(pure yreE) + } + $(pure reqExp')) |] + SubsiteNested -> + -- Subsite: compose through the outer YesodSubRunnerEnv + [| Just (yesodSubDispatch + YesodSubRunnerEnv + { ysreParentRunner = ysreParentRunner $(pure yreE) + , ysreGetSub = $(pure sub2) . ysreGetSub $(pure yreE) + , ysreToParentRoute = ysreToParentRoute $(pure yreE) . $(pure routeLam) + , ysreParentEnv = ysreParentEnv $(pure yreE) + } + $(pure reqExp')) |] + return [Match (mkPathPat (EndRest restPath) pats) (NormalB body) []] + + genClauseForResource (ResourceParent name _check _attrs pieces _children) = do + (pats, dynVars) <- handlePiecesNames pieces + + -- Build the parent args tuple for the nested call + let allDynVars = parentDynVars ++ dynVars + parentArgsExp = parentArgsExpr allDynVars + routeConWrapper = applyConPieces name (map VarE dynVars) + + routeType <- appliedRouteTypeNamed name tyargs + + resultName <- newName "k" + + nestedCall <- + [| $(varE (nestedTargetFn nestedTarget)) + (Proxy :: Proxy $(pure routeType)) + $(pure parentArgsExp) + ($(pure toParentE) . $(pure routeConWrapper)) + $(pure yreE) + $(pure reqE) |] + + if roNestedRouteFallthrough routeOpts + then do + -- Fallthrough enabled: pattern-guard on a 'Just' result, so a + -- 'Nothing' from the delegated child lets dispatch fall through + -- to sibling clauses (and ultimately the 'Nothing' fallback). + let patGuard = BindS (conPCompat 'Just [VarP resultName]) nestedCall + guardedBody = GuardedB [(PatG [patGuard], ConE 'Just `AppE` VarE resultName)] + return [Match (mkPathPat EndWild pats) guardedBody []] + else do + -- Fallthrough disabled: once this parent's path prefix matches we + -- commit to its subtree. If the delegated child dispatch returns + -- 'Nothing', convert it to a 404 handler call rather than letting + -- the 'Nothing' propagate (which, under an outer fallthrough + -- caller, would let it fall through to siblings). This mirrors the + -- inline no-fallthrough path's @Nothing -> Just 404@ shape. + committedBody <- + [| Just (fromMaybe + ($(varE (nestedTargetRunner nestedTarget)) + (void notFound) $(pure yreE) Nothing $(pure reqE)) + $(pure nestedCall)) |] + return [Match (mkPathPat EndWild pats) (NormalB committedBody) []] + + genHandlerCase :: String -> [String] -> [Exp] -> Q Exp + genHandlerCase name methods allDynExps = do + let handlerExpFor mmethod = do + handlerName <- defaultGetHandler mmethod name + unwrapper $ foldl' AppE handlerName allDynExps + + if null methods + then do + -- No specific methods, just call handler + handlerE <- handlerExpFor Nothing + [| fmap toTypedContent $(pure handlerE) |] + else do + -- Generate method case + -- Wrap each handler with fmap toTypedContent so all branches have the same type + methodMatches <- forM methods $ \method -> do + handlerE <- handlerExpFor (Just method) + wrappedHandler <- [| fmap toTypedContent $(pure handlerE) |] + return $ Match (LitP $ StringL method) (NormalB wrappedHandler) [] + + badMethodHandler <- unwrapper (VarE 'badMethod) + let badMethodMatch = Match WildP (NormalB badMethodHandler) [] + scrutinee <- [| W.requestMethod $(pure reqE) |] + return $ CaseE scrutinee (methodMatches ++ [badMethodMatch]) + +mkYesodSubDispatch :: [ResourceTree a] -> Q Exp +mkYesodSubDispatch = mkYesodSubDispatchWith defaultOpts + +-- | Like 'mkYesodSubDispatch', but threads a 'RouteOpts' into the generated +-- @yesodSubDispatch@ body. The only option that affects the body is +-- 'roNestedRouteFallthrough', which controls whether a subsite's top-level +-- parent clause falls through to a later sibling on an inner miss (mirroring +-- 'mkTopLevelDispatchInstance'). 'mkYesodSubDispatch' keeps the opts-less +-- signature for backwards compatibility. +-- +-- This standalone entry point never delegates a parent's dispatch to a +-- same-splice 'YesodSubDispatchNested' instance: when called on its own there +-- are no such instances being generated alongside it (delegating would emit a +-- reference to a missing instance). 'mkYesodSubDispatchInstanceOpts', which +-- /does/ generate the matching nested instances in the same splice, uses +-- 'mkYesodSubDispatchWithDelegate' to opt into delegation. +-- +-- @since 1.7.0.0 +mkYesodSubDispatchWith :: RouteOpts -> [ResourceTree a] -> Q Exp +mkYesodSubDispatchWith = mkYesodSubDispatchWithDelegate NoSameSpliceNestedInstances + +-- | The body-generation core shared by the standalone 'mkYesodSubDispatchWith' +-- and the instance-generating 'mkYesodSubDispatchInstanceOpts'. The +-- 'SameSpliceNestedInstances' argument says whether the caller emits the +-- per-parent 'YesodSubDispatchNested' instances in the same splice — see that +-- type for what each choice means for the generated body. +-- +-- @since 1.7.0.0 +mkYesodSubDispatchWithDelegate + :: SameSpliceNestedInstances -> RouteOpts -> [ResourceTree a] -> Q Exp +mkYesodSubDispatchWithDelegate sameSplice routeOpts res = do + let mds = (mkMDS + return + [|subHelper|] + [|subTopDispatch|]) + { mdsNestedTarget = SubsiteNested + , mdsNestedRouteFallthrough = roNestedRouteFallthrough routeOpts + , mdsSameSpliceNestedInstances = sameSplice + } + (_childNames, clause') <- + mkDispatchClause + NoTyArgs + mds + res + inner <- newName "inner" + let innerFun = FunD inner [clause'] + helper <- newName "helper" + let fun = FunD helper + [ Clause + [] + (NormalB $ VarE inner) + [innerFun] + ] + return $ LetE [fun] (VarE helper) + + +subTopDispatch :: + (YesodSubDispatch sub master) => + (forall content. ToTypedContent content => + SubHandlerFor child master content -> + YesodSubRunnerEnv child master -> + Maybe (Route child) -> + W.Application + ) -> + (mid -> sub) -> + (Route sub -> Route mid) -> + YesodSubRunnerEnv mid master -> + W.Application +subTopDispatch _ getSub toParent env = + yesodSubDispatch + ( YesodSubRunnerEnv + { ysreParentRunner = ysreParentRunner env + , ysreGetSub = getSub . ysreGetSub env + , ysreToParentRoute = ysreToParentRoute env . toParent + , ysreParentEnv = ysreParentEnv env + } + ) + +mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b +mkMDS unwrapper runHandlerE subDispatcher = MkDispatchSettings + { mdsRunHandler = runHandlerE + , mdsSubDispatcher = subDispatcher + , mdsGetPathInfo = [|W.pathInfo|] + , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] + , mdsMethod = [|W.requestMethod|] + , mds404 = [|void notFound|] + , mds405 = [|void badMethod|] + , mdsGetHandler = defaultGetHandler + , mdsUnwrapper = unwrapper + , mdsNestedRouteFallthrough = False + , mdsNestedTarget = TopLevelNested + , mdsSameSpliceNestedInstances = NoSameSpliceNestedInstances + } + +-- | Parse the foundation-type string given to @mkYesod@ into its components: +-- the type-constructor name, its type arguments, and the @=>@ class-context +-- groups (each a class name applied to type arguments). Returns 'Left' with a +-- parse-error message on malformed input. +-- +-- @since 1.7.0.0 +parseYesodName :: String -> Either String (String, [String], [[String]]) +parseYesodName name = do + either (Left . show) Right $ parse parseName "" name + where + parseName = do + cxt <- option [] parseContext + name' <- parseWord + args <- many parseWord + spaces + eof + return ( name', args, cxt) + + parseWord = do + spaces + many1 alphaNum + + parseContext = try $ do + cxts <- parseParen parseContexts + spaces + _ <- string "=>" + return cxts + + parseParen p = do + spaces + _ <- char '(' + r <- p + spaces + _ <- char ')' + return r + + parseContexts = + sepBy1 (many1 parseWord) (spaces >> char ',' >> return ()) diff --git a/src/Yesod/Routes/TH/Internal.hs b/src/Yesod/Routes/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Routes/TH/Internal.hs @@ -0,0 +1,412 @@ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} + +module Yesod.Routes.TH.Internal where + +import Prelude hiding (exp) +import Data.List (foldl') +import Data.Maybe (mapMaybe) +-- newName is hidden so the only one in scope is the 'Quote' class method +-- (re-exported by th-compat); with template-haskell < 2.17 the monomorphic +-- 'Language.Haskell.TH.Syntax.newName' is a distinct, ambiguous name. +import Language.Haskell.TH.Syntax hiding (newName) +import Language.Haskell.TH.Syntax.Compat (Quote(..)) +import Web.PathPieces (fromPathPiece, fromPathMultiPiece) +import Yesod.Routes.TH.Types + +conPCompat :: Name -> [Pat] -> Pat +conPCompat n pats = ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + pats + +instanceD :: Cxt -> Type -> [Dec] -> Dec +instanceD = InstanceD Nothing + +mkTupE :: [Exp] -> Exp +mkTupE = + TupE +#if MIN_VERSION_template_haskell(2,16,0) + . fmap Just +#endif + +-- | The expression form of a route's accumulated @ParentArgs@: @()@ when there +-- are no dynamic pieces, the lone expression when there is one, and a tuple of +-- them otherwise. This is the single spelling of the unit\/single\/tuple idiom +-- that recurred across the dispatch and render-route clause builders. +parentArgsExprFromExps :: [Exp] -> Exp +parentArgsExprFromExps [] = ConE '() +parentArgsExprFromExps [e] = e +parentArgsExprFromExps es = mkTupE es + +-- | 'parentArgsExprFromExps' for the common case where the arguments are plain +-- variable names. +parentArgsExpr :: [Name] -> Exp +parentArgsExpr = parentArgsExprFromExps . map VarE + +-- | The /pattern/ form of a route's accumulated @ParentArgs@, for binding the +-- incoming parent arguments: @_@ when there are none (the @ParentArgs@ is @()@ +-- and ignored), the lone variable when there is one, and a tuple otherwise. +parentArgsPat :: [Name] -> Pat +parentArgsPat [] = WildP +parentArgsPat [a] = VarP a +parentArgsPat as = TupP (map VarP as) + +-- | The /type/ form of a route's accumulated @ParentArgs@: the unit type when +-- there are no dynamic pieces, the lone type when there is one, and a tuple +-- type otherwise. +parentArgsType :: [Type] -> Type +parentArgsType [] = ConT ''() +parentArgsType [t] = t +parentArgsType ts = foldl' AppT (TupleT (length ts)) ts + +-- | The number of type parameters a type constructor declares (0 for a type +-- that isn't a data\/newtype\/type-synonym, or that we can't reify). +typeArity :: Name -> Q Int +typeArity typeName = do + info <- reify typeName + pure $ case info of + TyConI (DataD _ _ vs _ _ _) -> length vs + TyConI (NewtypeD _ _ vs _ _ _) -> length vs + TyConI (TySynD _ vs _) -> length vs + _ -> 0 + +-- | Look up a type by 'Name' and return it fully applied with fresh +-- type variables. This is needed because nested route datatypes may +-- have type parameters (e.g., @NestedR subsite@), and TH functions +-- like 'isInstance' require fully-applied (kind 'Type') heads. +-- +-- The application is to the datatype's /own/ reified 'typeArity', so the head +-- is saturated exactly — neither under- nor over-applied — and is therefore +-- well-kinded by construction. This holds for higher-kinded parameters too: +-- a parameter declared @(f :: Type -> Type)@ is filled with a bare, +-- unannotated @'VarT' a@, and GHC infers @a :: Type -> Type@ from the +-- datatype's declared kind, so we don't need to reconstruct each parameter's +-- kind ourselves. (Saturating by some /other/ arity — e.g. a caller's +-- 'TyArgs' count — is what historically built ill-kinded heads and made +-- 'isInstance' throw; see 'nestedInstanceExists'.) +fullyApplyType :: Name -> Q Type +fullyApplyType typeName = do + arity <- typeArity typeName + vars <- mapM (\i -> VarT <$> newName ("a" ++ show i)) [1..arity] + pure $ foldl' AppT (ConT typeName) vars + +-- | A route datatype name paired with the result of resolving it in the +-- current splice environment. 'rcResolved' is 'Just' when the datatype is +-- already in scope (defined in an earlier splice or a separately compiled +-- module) and 'Nothing' when it is not yet — typically because it is being +-- generated in the same splice group. +-- +-- The point is to resolve a route name /once/, at the boundary, and carry the +-- answer in a value rather than re-running 'lookupTypeName' at each use site +-- and independently re-deciding what an unresolved name means. The two +-- consumers that matter — \"does its nested instance already exist?\" +-- ('nestedInstanceExists') and \"what type head do I splice?\" +-- ('appliedRouteTypeCon') — then share a single resolution. +-- +-- @since 1.7.0.0 +data RouteCon = RouteCon + { rcName :: String -- ^ the route datatype name as written + , rcResolved :: Maybe Name -- ^ the resolved 'Name', if in scope + } + +-- | Resolve a route datatype name with 'lookupTypeName'. This is the single +-- boundary at which a route name is looked up; downstream code branches on the +-- resulting 'RouteCon' instead of resolving again. +-- +-- @since 1.7.0.0 +resolveRouteCon :: String -> Q RouteCon +resolveRouteCon name = RouteCon name <$> lookupTypeName name + +-- | Does an instance of the given (nested-discovery) class — e.g. +-- @''YesodDispatchNested@, @''RenderRouteNested@, @''ParseRouteNested@, +-- @''RouteAttrsNested@ — already exist for this route datatype? This is the +-- single delegation probe shared by all the generators: when it answers 'True' +-- the parent delegates to the existing instance, and when 'False' it inlines +-- (or generates) the child itself. +-- +-- Two rules, applied uniformly so the probe can never abort a splice: +-- +-- * An unresolved 'RouteCon' (the datatype is being generated in the same +-- splice) trivially has no instance yet, so the answer is 'False'. +-- * A resolved one is saturated by its /own/ reified arity via +-- 'fullyApplyType' — never by the site's 'TyArgs'. Applying the site's +-- type args to a child that was generated at a different arity (e.g. a +-- kind-'Type' child of a parameterized site) builds an ill-kinded head, +-- and 'isInstance' /throws/ a kind error rather than returning 'False', +-- aborting the splice. Saturating by the datatype's own arity keeps the +-- probed head well-kinded in every case. +-- +-- /Can the abstract parameters make 'isInstance' fail?/ No. Once the head is +-- well-kinded (above), 'isInstance' answers by head unification — \"could +-- /any/ visible instance match this head?\" — which is a total query: it +-- returns 'True' or 'False' but cannot crash on an abstract @'VarT' a@. The +-- one theoretical imprecision is /over-matching/: because the argument is an +-- unconstrained variable, an instance written only at a more specific type +-- (e.g. @instance C (R Int)@) would still unify with @C (R a)@ and report +-- 'True'. That is harmless here because our codegen emits the nested-discovery +-- instances uniformly, one per route datatype at a fully abstract parameter +-- (e.g. @instance YesodDispatchNested (R a)@), so \"could match\" and \"does +-- match\" coincide — there is no narrower instance for the probe to confuse a +-- variable with. (Higher-kinded parameters are covered by the same argument; +-- see 'fullyApplyType'.) +-- +-- @since 1.7.0.0 +nestedInstanceExists :: Name -> RouteCon -> Q Bool +nestedInstanceExists klass rc = + case rcResolved rc of + Nothing -> pure False + Just typeName -> do + appliedT <- fullyApplyType typeName + isInstance klass [appliedT] + +-- | The fully-applied route 'Type' for a 'RouteCon', as used for an instance +-- head. This is the single place the \"saturate by site 'TyArgs' vs. by the +-- datatype's own reified arity\" choice is made: +-- +-- * With explicit 'TyArgs' (a parameterized site) the supplied type +-- arguments are applied to the constructor — the resolved 'Name' if in +-- scope, otherwise the bare 'mkName' (so a datatype being generated in the +-- same splice still gets a head to reference). +-- * With 'NoTyArgs' a resolved datatype is reified and saturated with fresh +-- type variables (needed for e.g. @mkYesodSubDispatch@, which doesn't know +-- the parent's type args); an unresolved one falls back to the bare +-- constructor. +-- +-- @since 1.7.0.0 +appliedRouteTypeCon :: RouteCon -> TyArgs -> Q Type +appliedRouteTypeCon rc tyargs = + case (rcResolved rc, tyargs) of + (Just typeName, NoTyArgs) -> fullyApplyType typeName + (Just typeName, SomeTyArgs{}) -> pure $ applyTyArgs (ConT typeName) tyargs + (Nothing, _) -> pure $ applyTyArgs (ConT (mkName (rcName rc))) tyargs + +-- | 'appliedRouteTypeCon' starting from the route datatype's name as a +-- 'String': resolve it ('resolveRouteCon') and apply the type arguments. The +-- fallback for an unresolved name (the bare constructor) is why this can't be +-- a plain @'lookupTypeName' >>=@ that requires the name to be in scope. +appliedRouteTypeNamed :: String -> TyArgs -> Q Type +appliedRouteTypeNamed routeName tyargs = do + rc <- resolveRouteCon routeName + appliedRouteTypeCon rc tyargs + +-- | A subsite's type-constructor name. Distinct from 'RouteName' so the two +-- can't be swapped at a 'checkNestedSubArity' call site without a type error. +-- +-- @since 1.7.0.0 +newtype SubsiteName = SubsiteName String deriving (Eq, Show) + +-- | A nested route datatype's name. See 'SubsiteName'. +-- +-- @since 1.7.0.0 +newtype RouteName = RouteName String deriving (Eq, Show) + +-- | How many type arguments a subsite has. Distinct from 'RouteArity' so the +-- two arities can't be swapped (the equality predicate is symmetric, but the +-- error message is not). +-- +-- @since 1.7.0.0 +newtype SubsiteArity = SubsiteArity Int deriving (Eq, Show) + +-- | The declared type-parameter arity of a nested route datatype. See +-- 'SubsiteArity'. +-- +-- @since 1.7.0.0 +newtype RouteArity = RouteArity Int deriving (Eq, Show) + +-- | A detected mismatch between a subsite's type-argument count and its nested +-- route datatype's declared arity. Carrying the four facts (rather than a +-- pre-rendered 'String') lets the caller decide how to surface it and lets +-- tests assert on structure instead of substring-matching a message. +-- +-- @since 1.7.0.0 +data ArityMismatch = ArityMismatch + { amSubsiteName :: SubsiteName + , amRouteName :: RouteName + , amSubsiteArity :: SubsiteArity + , amRouteArity :: RouteArity + } deriving (Eq, Show) + +-- | Validate that a parameterized subsite's nested route datatype carries +-- exactly as many type parameters as the subsite has type arguments: 'Nothing' +-- when the arities match, or a structured 'ArityMismatch' otherwise. +-- +-- 'mkYesodSubDispatchInstance' applies the subsite's type arguments to each +-- nested route datatype (e.g. @NestedR subsite@) and uses the result directly +-- as the head of a @YesodSubDispatchNested@ instance, which expects a fully +-- applied (kind 'Type') route. So the arities must match exactly: +-- +-- * Too few parameters on the nested datatype (e.g. it was generated by +-- plain 'mkYesodSubData', kind 'Type') over-applies it. +-- * Too many leaves it partially applied (kind @Type -> ...@). +-- +-- Either way the result is a kind error reported deep inside generated code. +-- Surfacing it here (the caller passes the 'ArityMismatch' to 'fail') turns +-- it into an actionable, attributable message. +-- +-- Pure so it can be unit-tested directly. +-- +-- @since 1.7.0.0 +checkNestedSubArity + :: SubsiteName + -> RouteName + -> SubsiteArity + -> RouteArity + -> Maybe ArityMismatch +checkNestedSubArity subName routeName (SubsiteArity subArgs) (RouteArity nestedArity) + | subArgs == nestedArity = Nothing + | otherwise = Just $ ArityMismatch subName routeName (SubsiteArity subArgs) (RouteArity nestedArity) + +-- | Which generator is running the arity check. The arity facts are identical +-- either way; this only steers 'arityMismatchMessage' so the failure names the +-- right entry point and calls the parameterized thing by its correct term +-- (a top-level site reached through the nested-dispatch recursion is not a +-- \"subsite\"). +-- +-- @since 1.7.0.0 +data ArityCallSite + = SubsiteCall -- ^ a subsite, generated by 'mkYesodSubDispatchInstance' + | TopLevelCall -- ^ a top-level site's nested-dispatch recursion + deriving (Eq, Show) + +-- | Run 'checkNestedSubArity' for a (possibly unresolved) nested route +-- datatype and 'fail' with 'arityMismatchMessage' on a mismatch. A no-op when +-- the datatype is not in scope — an unresolved name has no knowable arity, so +-- the error (if any) surfaces from the generated code instead. This is the +-- single arity-guard shared by 'mkYesodSubDispatchInstance' and the nested +-- dispatch-instance recursion. +-- +-- @since 1.7.0.0 +assertNestedSubArity :: ArityCallSite -> SubsiteName -> SubsiteArity -> RouteCon -> Q () +assertNestedSubArity callSite subName subArity rc = + case rcResolved rc of + Nothing -> pure () + Just tyname -> do + nestedArity <- typeArity tyname + maybe (pure ()) (fail . arityMismatchMessage callSite) $ + checkNestedSubArity subName (RouteName (rcName rc)) subArity (RouteArity nestedArity) + +-- | The actionable @fail@ message for an 'ArityMismatch', phrased for the +-- 'ArityCallSite' that detected it. +-- +-- @since 1.7.0.0 +arityMismatchMessage :: ArityCallSite -> ArityMismatch -> String +arityMismatchMessage callSite (ArityMismatch (SubsiteName subName) (RouteName routeName) (SubsiteArity subArgs) (RouteArity nestedArity)) = + concat + [ prefix, ": the nested route datatype `", routeName + , "` has ", show nestedArity, " type parameter(s), but the ", term, " `" + , subName, "` has ", show subArgs + , ". The subroute datatypes must carry exactly the ", term, "'s type " + , "parameter(s) — generate the ", term, "'s routes with " + , "`mkYesodSubDataOpts (setParameterizedSubroute True defaultOpts) ...` " + , "so a parameterized ", term, " gets parameterized subroutes." + ] + where + (prefix, term) = case callSite of + SubsiteCall -> ("mkYesodSubDispatchInstance", "subsite") + TopLevelCall -> ("mkYesod", "site") + +-- | Turn a single route piece into a match pattern, returning the freshly +-- bound 'Name' for dynamic pieces (and 'Nothing' for static ones). The +-- fresh-'Name' supply is the 'Quote' @m@ it runs in: the 'Q' code generators +-- run at 'Q' (hygienic 'newName'), while the pure, deterministic inline-parse +-- path runs at a 'Quote' instance over a monotonic counter (see the test +-- harness). This is the single source of truth for the +-- @ViewP fromPathPiece (Just x)@ dynamic encoding shared by the parse and +-- dispatch clause builders. +handlePieceM :: Quote m => Piece a -> m (Pat, Maybe Name) +handlePieceM (Static str) = pure (LitP $ StringL str, Nothing) +handlePieceM (Dynamic _) = mk <$> newName "dyn" + where + mk x = (ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x]), Just x) + +-- | The list form of 'handlePieceM' projecting the dynamic binders as 'Name's, +-- for callers that consume the bound variables directly (e.g. nested-dispatch +-- handler arguments). +handlePiecesNames :: Quote m => [Piece a] -> m ([Pat], [Name]) +handlePiecesNames = + fmap (\pps -> (map fst pps, mapMaybe snd pps)) . traverse handlePieceM + +-- | The list form of 'handlePieceM' projecting the dynamic binders as 'VarE' +-- expressions, for callers that rebuild a route by applying its constructor to +-- the captured pieces. +handlePiecesM :: Quote m => [Piece a] -> m ([Pat], [Exp]) +handlePiecesM = + fmap (\(pats, names) -> (pats, map VarE names)) . handlePiecesNames + +-- | Rebuild a route by applying its constructor (named by 'String', resolved +-- with 'mkName') to the captured dynamic-piece expressions — the companion to +-- 'handlePiecesM', which produces the @['Exp']@. This is the single spelling +-- of the @'foldl'' 'AppE' ('ConE' ('mkName' name))@ route-construction idiom +-- that recurred across the dispatch and parse clause builders. +applyConPieces :: String -> [Exp] -> Exp +applyConPieces name = foldl' AppE (ConE (mkName name)) + +-- | @composeE f g@ is the expression @f . g@. +composeE :: Exp -> Exp -> Exp +composeE f g = InfixE (Just f) (VarE '(.)) (Just g) + +-- | @consE x xs@ is the expression @x : xs@. +consE :: Exp -> Exp -> Exp +consE x xs = InfixE (Just x) (ConE '(:)) (Just xs) + +-- | How a path match pattern ends, after its matched piece patterns. Only +-- these four shapes are ever valid as a path tail, so making it a closed type +-- (rather than an arbitrary 'Pat') stops a caller from silently matching the +-- wrong number of segments — e.g. binding a @rest@ where the path was meant to +-- end exactly. +data PathTail + = EndExact -- ^ @[]@ — the path ends exactly here + | EndRest Name -- ^ bind the remaining segments to the given variable + | EndWild -- ^ @_@ — ignore any remaining segments + | EndMulti Name -- ^ a trailing multipiece: @'fromPathMultiPiece' -> 'Just' n@ + +-- | The 'Pat' a 'PathTail' denotes (the seed the matched piece patterns are +-- consed onto in 'mkPathPat'). +pathTailPat :: PathTail -> Pat +pathTailPat EndExact = conPCompat '[] [] +pathTailPat (EndRest n) = VarP n +pathTailPat EndWild = WildP +pathTailPat (EndMulti n) = ViewP (VarE 'fromPathMultiPiece) (conPCompat 'Just [VarP n]) + +-- | Build a path match pattern: a list pattern of the given piece patterns +-- ending in the given 'PathTail'. +mkPathPat :: PathTail -> [Pat] -> Pat +mkPathPat tl = foldr (\x y -> conPCompat '(:) [x, y]) (pathTailPat tl) + +-- | Generate a single-argument lambda expression with a fresh name. +-- Takes a base name hint, generates a unique 'Name', and passes it +-- to a callback that produces the lambda body. Returns the complete +-- 'LamE' expression. +-- +-- For multi-argument lambdas, nest calls — @\\x y -> body@ is +-- equivalent to @\\x -> \\y -> body@. +mkLambda :: String -> (Name -> Q Exp) -> Q Exp +mkLambda hint mkBody = do + n <- newName hint + bdy <- mkBody n + pure $ LamE [VarP n] bdy + +-- | Given a target 'String', find the 'ResourceParent' in the +-- @['ResourceTree' a]@ corresponding to that target and return it. +-- Also return the @['Piece' a]@ captures that precede it. +findNestedRoute :: String -> [ResourceTree a] -> Maybe ([Piece a], [ResourceTree a]) +findNestedRoute _ [] = Nothing +findNestedRoute target (res : ress) = + case res of + ResourceLeaf _ -> + findNestedRoute target ress + ResourceParent name _overlap _attrs pieces children -> do + if name == target + then Just (pieces, children) + else + let mresult = findNestedRoute target children + in + case mresult of + Nothing -> do + findNestedRoute target ress + Just (typs, childRoute) -> do + Just (pieces <> typs, childRoute) diff --git a/src/Yesod/Routes/TH/ParseRoute.hs b/src/Yesod/Routes/TH/ParseRoute.hs --- a/src/Yesod/Routes/TH/ParseRoute.hs +++ b/src/Yesod/Routes/TH/ParseRoute.hs @@ -1,48 +1,334 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} module Yesod.Routes.TH.ParseRoute ( -- ** ParseRoute mkParseRouteInstance + , mkParseRouteInstanceOpts + , mkParseRouteInstanceFor + -- ** Clause construction (monad-polymorphic over 'Quote'; testable purely) + , buildInlineParseClauses + , generateParseRouteClause ) where +import qualified Control.Monad.Trans as Trans +import qualified Data.Set as Set +import Control.Monad import Yesod.Routes.TH.Types -import Language.Haskell.TH.Syntax -import Data.Text (Text) +import Language.Haskell.TH (varE, varP) +import Language.Haskell.TH.Syntax hiding (newName) +import Language.Haskell.TH.Syntax.Compat (Quote(..), unsafeQToQuote) import Yesod.Routes.Class -import Yesod.Routes.TH.Dispatch +import Yesod.Routes.TH.RenderRoute +import Control.Monad.State.Strict +import Yesod.Routes.TH.Internal -mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec -mkParseRouteInstance cxt typ ress = do - cls <- mkDispatchClause - MkDispatchSettings - { mdsRunHandler = [|\_ _ x _ -> x|] - , mds404 = [|error "mds404"|] - , mds405 = [|error "mds405"|] - , mdsGetPathInfo = [|fst|] - , mdsMethod = [|error "mdsMethod"|] - , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|] - , mdsSetPathInfo = [|\p (_, q) -> (p, q)|] - , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|] - , mdsUnwrapper = return - } - (map removeMethods ress) - helper <- newName "helper" - fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|] - return $ instanceD cxt (ConT ''ParseRoute `AppT` typ) - [ FunD 'parseRoute $ return $ Clause - [] - (NormalB $ fixer `AppE` VarE helper) - [FunD helper [cls]] - ] +-- | The trailing @_ -> Nothing@ clause appended to every generated +-- @parseRoute@\/@parseRouteNested@: a path matching none of the preceding +-- clauses fails to parse. +missingRouteClause :: Clause +missingRouteClause = Clause [WildP] (NormalB (ConE 'Nothing)) [] + +mkParseRouteInstance :: TyArgs -> Cxt -> Type -> [ResourceTree a] -> Q [Dec] +mkParseRouteInstance = + mkParseRouteInstanceOpts defaultOpts + +-- | Generate a ParseRouteNested instance for a specific nested route target. +-- This is a convenience wrapper around mkParseRouteInstanceOpts with setFocusOnNestedRoute. +-- +-- @since 1.7.0.0 +mkParseRouteInstanceFor :: String -> [ResourceTree a] -> Q [Dec] +mkParseRouteInstanceFor target ress = do + let opts = setFocusOnNestedRoute target defaultOpts + targetType = ConT (mkName target) + mkParseRouteInstanceOpts opts NoTyArgs [] targetType ress + +-- | Generate the 'ParseRoute' instance (and, under nested discovery, the +-- accompanying 'ParseRouteNested' instances) for a site, honoring the supplied +-- 'RouteOpts' and the site's 'TyArgs'. The options-driven core that +-- 'mkParseRouteInstanceFor' and the @mkYesod@ entry points build on. +-- +-- @since 1.7.0.0 +mkParseRouteInstanceOpts :: RouteOpts -> TyArgs -> Cxt -> Type -> [ResourceTree a] -> Q [Dec] +mkParseRouteInstanceOpts routeOpts origTyargs cxt typ unfocusedRess = + case discoveryMode routeOpts origTyargs of + -- Backwards-compatible default: generate a single 'ParseRoute' + -- instance with all nested routes inlined, and no 'ParseRouteNested' + -- instances. + InlineCompat -> do + clausess <- mapM (buildInlineParseClauses id) unfocusedRess + let allClauses = concat clausess <> [missingRouteClause] + pure + [ instanceD cxt (ConT ''ParseRoute `AppT` typ) + [ FunD 'parseRoute allClauses + ] + ] + NestedDiscovery -> do + ress <- focusTarget unfocusedRess + existingInstances <- existingNestedInstances ress + (clauses, childNames) <- flip runStateT mempty $ traverse (generateParseRouteClause existingInstances routeOpts) ress + + childInstances <- fmap join $ forM (Set.toList childNames) $ \childName -> + mkParseRouteInstanceOpts routeOpts { roFocusOnNestedRoute = Just childName } origTyargs cxt (targetTypeFor childName) ress + + let allClauses = clauses <> [missingRouteClause] + + let thisInstance = + case roFocusOnNestedRoute routeOpts of + Just target -> + instanceD cxt (ConT ''ParseRouteNested `AppT` targetTypeFor target) + [ FunD 'parseRouteNested allClauses + ] + Nothing -> + instanceD cxt (ConT ''ParseRoute `AppT` typ) + [ FunD 'parseRoute allClauses + ] + + pure $ thisInstance : childInstances where - -- We do this in order to ski the unnecessary method parsing - removeMethods (ResourceLeaf res) = ResourceLeaf $ removeMethodsLeaf res - removeMethods (ResourceParent w x y z) = ResourceParent w x y $ map removeMethods z + -- The route datatype named by @name@, applied to the site's type arguments. + targetTypeFor name = applyTyArgs (ConT (mkName name)) origTyargs - removeMethodsLeaf res = res { resourceDispatch = fixDispatch $ resourceDispatch res } + -- Narrow to the focused subtree's children via the shared lookup, failing + -- loudly (matching Dispatch/RenderRoute) when the target is missing rather + -- than silently producing an always-'Nothing' 'ParseRouteNested' instance. + focusTarget ts = + case roFocusOnNestedRoute routeOpts of + Just target -> + case findNestedRoute target ts of + Nothing -> + fail $ "Target '" ++ target ++ "' was not found in resources." + Just (_prePieces, children) -> + pure children + Nothing -> + pure ts - fixDispatch (Methods x _) = Methods x [] - fixDispatch x = x +-- | Probe (in 'Q') which of the given resources' top-level parents already +-- have a 'ParseRouteNested' instance. Pulling these compiler queries +-- ('isInstance', via 'nestedInstanceExists') out of 'generateParseRouteClause' +-- is what lets that generator be monad-polymorphic over 'Quote' — and thus +-- runnable, and testable, at a pure 'Quote' instance. +-- +-- @since 1.7.0.0 +existingNestedInstances :: [ResourceTree a] -> Q (Set.Set String) +existingNestedInstances ress = do + flags <- mapM check ress + pure $ Set.fromList (concat flags) + where + check (ResourceParent name _ _ _ _) = do + rc <- resolveRouteCon name + has <- nestedInstanceExists ''ParseRouteNested rc + pure [name | has] + check ResourceLeaf{} = pure [] -instanceD :: Cxt -> Type -> [Dec] -> Dec -instanceD = InstanceD Nothing +-- | Generate a single @parseRouteNested@-delegating clause for one resource +-- (under nested discovery). It records, into its 'StateT' accumulator, the +-- name of each parent that still needs a 'ParseRouteNested' instance generated. +-- +-- The \"does this name already have an instance?\" decision is a compiler query +-- ('isInstance'), which would pin this to 'Q'; it is instead /hoisted out/ and +-- passed in as @existingInstances@, leaving only fresh-name generation as an +-- effect. That makes the generator monad-polymorphic over 'Quote': it runs at +-- 'Q' in production and at a pure 'Quote' instance (a monotonic counter) in +-- tests. +-- +-- @since 1.7.0.0 +generateParseRouteClause + :: Quote m + => Set.Set String + -- ^ Route names that already have a 'ParseRouteNested' instance (so this + -- clause should not re-request one). Computed by the caller in 'Q' via + -- 'nestedInstanceExists'; pass 'mempty' in pure tests. + -> RouteOpts + -> ResourceTree a + -> StateT (Set.Set String) m Clause +generateParseRouteClause existingInstances routeOpts resourceTree = + case resourceTree of + ResourceLeaf (Resource name pieces dispatch _ _check) -> do + (pats, dyns) <- liftQ $ handlePiecesM pieces + + case dispatch of + Methods multi _ -> do + (finalTail, dyns') <- + case multi of + Nothing -> + pure (EndExact, dyns) + Just _ -> do + multiName <- liftQ $ newName "multi" + pure (EndMulti multiName, dyns ++ [VarE multiName]) + + queryParamsName <- liftQ $ newName "_queryParams" + let route = applyConPieces name dyns' + jroute = ConE 'Just `AppE` route + pathPat = mkPathPat finalTail pats + pat = TupP [pathPat, VarP queryParamsName] + pure $ Clause [pat] (NormalB jroute) [] + + Subsite _ _ -> do + restName <- liftQ $ newName "rest" + queryParamsName <- liftQ $ newName "_queryParams" + + let route = applyConPieces name dyns + pathPat = mkPathPat (EndRest restName) pats + pat = TupP [pathPat, VarP queryParamsName] + tupExp = mkTupE [VarE restName, VarE queryParamsName] + expr = VarE 'fmap + `AppE` route + `AppE` (VarE 'parseRoute `AppE` tupExp) + pure $ Clause [pat] (NormalB expr) [] + + ResourceParent name _check _attrs pieces _children -> do + recordNameIfNotInstance name + + (pats, dyns) <- liftQ $ handlePiecesM pieces + + let route = applyConPieces name dyns + + restName <- liftQ $ newName "rest" + queryParamsName <- liftQ $ newName "_queryParams" + + let parseRouteOnRest = + VarE 'parseRouteNested + `AppE` mkTupE [VarE restName, VarE queryParamsName] + + body <- + if roNestedRouteFallthrough routeOpts + then do + resultName <- liftQ $ newName "result" + let stmt = BindS (AsP resultName (conPCompat 'Just [WildP])) parseRouteOnRest + expr = VarE 'fmap `AppE` route `AppE` VarE resultName + pure $ GuardedB [(PatG [stmt], expr)] + else + pure $ NormalB (VarE 'fmap `AppE` route `AppE` parseRouteOnRest) + + let pat = TupP [mkPathPat (EndRest restName) pats, VarP queryParamsName] + pure $ Clause [pat] body [] + + where + liftQ :: Monad n => n a -> StateT (Set.Set String) n a + liftQ = Trans.lift + + -- Record that @name@ still needs a 'ParseRouteNested' instance generated. + -- The instance-existence decision is hoisted out (into @existingInstances@, + -- computed in 'Q' by the caller), so this stays pure. + recordNameIfNotInstance name = + unless (name `Set.member` existingInstances) $ + modify (Set.insert name) + +-- | Backwards-compatible inline @parseRoute@ clause generation. It assembles +-- the @parseRoute@ clauses for the inline path directly as AST, drawing fresh +-- names from a 'Quote' name supply and building tuples\/applications by hand +-- rather than through quotation brackets +-- (brackets are monomorphic 'Q' before template-haskell 2.17; the one +-- exception goes through 'unsafeQToQuote'). +-- +-- Each call yields one clause per resource tree: a leaf is its own matching +-- clause, while a parent is a single clause that matches its path prefix and +-- then cases the remaining @(path, queryParams)@ over its children (their +-- clauses turned into match alternatives) ending in a @_ -> 'Nothing'@ +-- fallback. That fallback is the commit-on-parent-prefix behaviour: once the +-- parent prefix matches, a child miss is a definite 'Nothing' rather than a +-- fall-through to a sibling top-level route. +-- +-- It is monad-polymorphic in the name supply via 'Quote': production runs it at +-- 'Q' (so binders are hygienic 'newName's), while tests run it at a pure +-- 'Quote' instance backed by a monotonic counter, where names are deterministic +-- and the '[Clause]' output can be asserted on directly without splicing or +-- 'runQ'. Under the deterministic supply every name is a freshly-bound pattern +-- variable scoped to its clause, the shared counter keeps them distinct within a +-- tree, and it is threaded through the parent\/child recursion so a parent +-- binder never collides with a child's. +-- +-- @since 1.7.0.0 +buildInlineParseClauses + :: Quote m + => (Exp -> Exp) + -- ^ Wrap a child-route expression in the accumulated parent constructors. + -> ResourceTree a + -> m [Clause] +buildInlineParseClauses wrap resourceTree = + map matchToClause <$> buildInlineParseMatches wrap resourceTree + where + -- Each parse match is a single @(path, queryParams)@ pattern with a body, + -- which is exactly a top-level @parseRoute@ clause. Total by construction — + -- 'Match' and 'Clause' carry the same body\/@where@ shape — so no partial + -- destructure is needed. + matchToClause :: Match -> Clause + matchToClause (Match pat body decs) = Clause [pat] body decs + +-- | The matching alternatives behind 'buildInlineParseClauses', one per +-- resource tree. Producing 'Match'es (rather than 'Clause's) is what lets a +-- parent splice its children straight into a @case@: a leaf is one +-- @(path, queryParams)@ alternative, and a parent is one alternative that +-- matches its path prefix then cases the remaining @(path, queryParams)@ over +-- its children's alternatives, ending in a @_ -> 'Nothing'@ fallback. At top +-- level 'buildInlineParseClauses' turns each alternative back into its own +-- @parseRoute@ clause. +buildInlineParseMatches + :: Quote m + => (Exp -> Exp) + -- ^ Wrap a child-route expression in the accumulated parent constructors. + -> ResourceTree a + -> m [Match] +buildInlineParseMatches wrap resourceTree = + case resourceTree of + ResourceLeaf (Resource name pieces dispatch _ _check) -> do + (pats, dyns) <- handlePiecesM pieces + case dispatch of + Methods multi _ -> do + (finalTail, dyns') <- + case multi of + Nothing -> + pure (EndExact, dyns) + Just _ -> do + multiName <- newName "multi" + pure (EndMulti multiName, dyns ++ [VarE multiName]) + queryParamsName <- newName "_queryParams" + let route = applyConPieces name dyns' + jroute = ConE 'Just `AppE` wrap route + pathPat = mkPathPat finalTail pats + pat = TupP [pathPat, VarP queryParamsName] + pure [Match pat (NormalB jroute) []] + + Subsite _ _ -> do + restName <- newName "rest" + queryParamsName <- newName "_queryParams" + subName <- newName "sub" + let route = applyConPieces name dyns + wrapSub = wrap (route `AppE` VarE subName) + pathPat = mkPathPat (EndRest restName) pats + pat = TupP [pathPat, VarP queryParamsName] + -- 'unsafeQToQuote' because brackets are monomorphic 'Q' + -- on template-haskell < 2.17. It is safe here: the only + -- effect a bracket performs is drawing hygiene names for + -- its binders, and this one has none (the lambda binder + -- comes from a splice). + expr <- unsafeQToQuote [e| + fmap + (\ $(varP subName) -> $(pure wrapSub) ) + (parseRoute ( $(varE restName), $(varE queryParamsName) ) ) + |] + pure [Match pat (NormalB expr) []] + + ResourceParent name _check _attrs pieces children -> do + (pats, dyns) <- handlePiecesM pieces + restName <- newName "rest" + queryParamsName <- newName "_queryParams" + let parentCon childRoute = + applyConPieces name dyns `AppE` childRoute + wrap' = wrap . parentCon + + -- Build each child's matching alternative relative to the remaining + -- @(rest, queryParams)@ scope, then fold them into a single @case@ + -- that commits at this parent: a child miss falls to the + -- @_ -> Nothing@ alternative instead of escaping to a sibling + -- top-level route. + childMatches <- concat <$> mapM (buildInlineParseMatches wrap') children + let restTup = mkTupE [VarE restName, VarE queryParamsName] + fallbackMatch = Match WildP (NormalB (ConE 'Nothing)) [] + caseExpr = CaseE restTup (childMatches ++ [fallbackMatch]) + pathPat = mkPathPat (EndRest restName) pats + pat = TupP [pathPat, VarP queryParamsName] + pure [Match pat (NormalB caseExpr) []] diff --git a/src/Yesod/Routes/TH/RenderRoute.hs b/src/Yesod/Routes/TH/RenderRoute.hs --- a/src/Yesod/Routes/TH/RenderRoute.hs +++ b/src/Yesod/Routes/TH/RenderRoute.hs @@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskellQuotes #-} +-- 'TemplateHaskellQuotes' is not enough here: on GHC < 9.0 it does not +-- enable nested @$(...)@ splices inside brackets (they parse as the @$@ +-- operator and trigger cross-stage 'Lift' errors). +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} @@ -8,7 +11,6 @@ ( -- ** RenderRoute mkRenderRouteInstanceOpts , mkRouteConsOpts - , mkRenderRouteClauses , shouldCreateResources , RouteOpts @@ -17,17 +19,28 @@ , setShowDerived , setReadDerived , setCreateResources + , setFocusOnNestedRoute + , unsetFocusOnNestedRoute + , roFocusOnNestedRoute + , roNestedRouteFallthrough , setParameterizedSubroute + , setNestedRouteFallthrough + , DiscoveryMode(..) + , discoveryMode ) where +import Data.Maybe import Yesod.Routes.TH.Types +import Language.Haskell.TH (varE, varP) import Language.Haskell.TH.Syntax -import Data.Maybe (maybeToList) -import Control.Monad (replicateM) +import Control.Monad import Data.Text (pack) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class import Data.Foldable +import Yesod.Routes.TH.Internal +import Data.Char +import Yesod.Core.Class.Dispatch.ToParentRoute -- | General opts data type for generating yesod. -- @@ -43,14 +56,38 @@ , roDerivedShow :: Bool , roDerivedRead :: Bool , roCreateResources :: Bool + , roFocusOnNestedRoute :: Maybe String + -- ^ If this option is set, then we will only generate datatypes for + -- the nested subroute that matches this string. + -- + -- @since 1.7.0.0 , roParameterizedSubroute :: Bool + , roNestedRouteFallthrough :: Bool + -- ^ If 'True', then a nested route will fall through if it fails to + -- match. If 'False', then a nested route will throw 'notFound' if it + -- does not match. + -- + -- Default: 'False'. + -- + -- @since 1.7.0.0 } -- | Default options for generating routes. -- --- Defaults to all instances derived, subroutes being unparameterized, and to --- create the @resourcesSite :: [ResourceTree String]@ term. +-- The defaults are: -- +-- * 'setEqDerived', 'setShowDerived', 'setReadDerived': 'True' — derive +-- 'Eq', 'Show' and 'Read' for the route datatype. +-- * 'setCreateResources': 'True' — emit the @resourcesSite :: +-- [ResourceTree String]@ term. +-- * 'setParameterizedSubroute': 'False' — subroutes are unparameterized. +-- * 'setFocusOnNestedRoute': unset — generate the whole route tree +-- rather than focusing on a single nested route. +-- * 'setNestedRouteFallthrough': 'False' — a nested route that fails to +-- match throws 'notFound' instead of falling through. +-- +-- Use the @set*@ functions to override individual fields. +-- -- @since 1.6.25.0 defaultOpts :: RouteOpts defaultOpts = MkRouteOpts @@ -59,22 +96,117 @@ , roDerivedRead = True , roCreateResources = True , roParameterizedSubroute = False + , roFocusOnNestedRoute = Nothing + , roNestedRouteFallthrough = False } --- | +-- | If you set this with @routeName@, then the code generation will +-- generate code for the @routeName@ to be imported in the main dispatch +-- class. This allows you to generate code in separate modules. -- +-- Example: +-- +-- First, you would put your route definitions into their own file. +-- +-- @ +-- module App.Routes.Resources where +-- +-- import Yesod.Core +-- +-- appResources :: [ResourceTree String] +-- appResources = [parseRoutes| +-- / HomeR GET +-- +-- /nest NestR: +-- / NestIndexR GET POST +-- /#Int NestShowR GET POST +-- +-- |] +-- @ +-- +-- We have defined a nested route called @NestR@ here. A nested route is +-- created with the @:@ after the route name. +-- +-- Then, in a module for the route specifically, we can generate the route +-- datatype and instances for later hooking in to the main instance. +-- +-- @ +-- module App.Routes.NestR where +-- +-- import App.Routes.Resources +-- import Yesod.Core +-- +-- mkYesodOpts (setFocusOnNestedRoute "NestR" defaultOpts) "App" appResources +-- @ +-- +-- If you only want to generate the datatypes, you can separate things +-- further using 'mkYesodDataOpts' and 'mkYesodDispatchOpts'. +-- +-- Finally, import that type into your main yesod macro code. +-- +-- @ +-- module App where +-- +-- import App.Routes.Resources (appResources) +-- import App.Routes.NestR (NestR(..)) +-- +-- mkYesod "App" appResources +-- @ +-- +-- The call to 'mkYesod' will delegate to the generated code for @NestR@ +-- rather than regenerating it. +-- +-- By default, 'defaultOpts' starts unfocused (the whole route tree is +-- generated). Use 'unsetFocusOnNestedRoute' to clear a previously-set focus. +-- +-- For a full walkthrough — including subsites, linking to nested routes, and +-- why split sites should enable 'setNestedRouteFallthrough' — see the guide at +-- . +-- +-- @since 1.7.0.0 +setFocusOnNestedRoute :: String -> RouteOpts -> RouteOpts +setFocusOnNestedRoute str rdo = rdo { roFocusOnNestedRoute = Just str } + +-- | Clear any nested-route focus set by 'setFocusOnNestedRoute', so that +-- the whole route tree is generated. +-- +-- 'defaultOpts' already starts unfocused, so this is only needed to undo a +-- previous 'setFocusOnNestedRoute'. +-- +-- @since 1.7.0.0 +unsetFocusOnNestedRoute :: RouteOpts -> RouteOpts +unsetFocusOnNestedRoute rdo = rdo { roFocusOnNestedRoute = Nothing } + +-- | When 'True', a nested route that fails to match falls through to the +-- enclosing dispatch rather than throwing 'notFound'. When 'False', a +-- non-matching nested route throws 'notFound'. +-- +-- Default: 'False'. +-- +-- @since 1.7.0.0 +setNestedRouteFallthrough :: Bool -> RouteOpts -> RouteOpts +setNestedRouteFallthrough b rdo = rdo { roNestedRouteFallthrough = b } + +-- | When 'True', derive an 'Eq' instance for the route datatype. +-- +-- Default: 'True'. +-- -- @since 1.6.25.0 setEqDerived :: Bool -> RouteOpts -> RouteOpts setEqDerived b rdo = rdo { roDerivedEq = b } --- | +-- | When 'True', derive a 'Show' instance for the route datatype. -- +-- Default: 'True'. +-- -- @since 1.6.25.0 setShowDerived :: Bool -> RouteOpts -> RouteOpts setShowDerived b rdo = rdo { roDerivedShow = b } --- | +-- | When 'True', derive a 'Read' instance for the route datatype. -- +-- Default: 'True'. +-- -- @since 1.6.25.0 setReadDerived :: Bool -> RouteOpts -> RouteOpts setReadDerived b rdo = rdo { roDerivedRead = b } @@ -86,6 +218,8 @@ -- here. The @resourcesApp@ can become very large in large applications, -- and duplicating it can result in signifiacntly higher compile times. -- +-- Default: 'True'. +-- -- @since 1.6.28.0 setCreateResources :: Bool -> RouteOpts -> RouteOpts setCreateResources b rdo = rdo { roCreateResources = b } @@ -97,8 +231,24 @@ shouldCreateResources :: RouteOpts -> Bool shouldCreateResources = roCreateResources --- | If True, we will correctly pass parameters for subroutes around. +-- | If True, generate nested-discovery code (separate subroute datatypes and +-- @RenderRouteNested@ / dispatch instances) for a /parameterized/ site instead +-- of the backwards-compatible inline output. The subroute datatypes then carry +-- the parent site's type variables so that the @ParentSite@ \/ @ParentArgs@ +-- associated types stay well-scoped. -- +-- Because the generated nested instances are parameterized over the site's +-- type variables, the splice emits instance heads with non-variable arguments; +-- a module using this typically needs @FlexibleContexts@, @FlexibleInstances@, +-- @MultiParamTypeClasses@, @TypeFamilies@ and, for a parameterized subsite +-- whose @master@ is determined by the @subsite@ (a @subsite -> master@ +-- functional dependency on the user's class), @UndecidableInstances@. +-- +-- Monomorphic sites always use nested discovery regardless of this flag; see +-- 'discoveryMode'. +-- +-- Default: 'False'. +-- -- @since 1.6.28.0 setParameterizedSubroute :: Bool -> RouteOpts -> RouteOpts setParameterizedSubroute b rdo = rdo { roParameterizedSubroute = b } @@ -110,106 +260,362 @@ instanceNamesFromOpts MkRouteOpts {..} = prependIf roDerivedEq ''Eq $ prependIf roDerivedShow ''Show $ prependIf roDerivedRead ''Read [] where prependIf b = if b then (:) else const id --- | Nullify the list unless we are using parameterised subroutes. -nullifyWhenNoParam :: RouteOpts -> [a] -> [a] -nullifyWhenNoParam opts = if roParameterizedSubroute opts then id else const [] +-- | How a route datatype's children are generated. +-- +-- @since 1.7.0.0 +data DiscoveryMode + = -- | The backwards-compatible default for a /parameterized/ site that has + -- not opted in: subroute datatypes stay unparameterized (kind 'Type') + -- and @renderRoute@ \/ @parseRoute@ \/ dispatch inline the children, + -- exactly as pre-nested-discovery Yesod did. Generating the discovery + -- machinery here would put the parent's type variables out of scope on + -- the child datatype, so we don't. + InlineCompat + | -- | Generate the "nested route discovery" machinery: parameterized + -- subroute datatypes plus the @RenderRouteNested@ \/ @ParseRouteNested@ + -- \/ @YesodDispatchNested@ \/ @ToParentRoute@ \/ @UrlToDispatch@ \/ + -- @RedirectUrl@ instances and the delegating method bodies that go with + -- them. + NestedDiscovery + deriving (Eq, Show) --- | Generate the constructors of a route data type, with custom opts. +-- | Classify how a route datatype's children should be generated, given the +-- site's route options and its 'TyArgs'. -- --- @since 1.6.25.0 -mkRouteConsOpts :: RouteOpts -> Cxt -> [(Type, Name)] -> [ResourceTree Type] -> ([Con], [Dec]) -mkRouteConsOpts opts cxt (nullifyWhenNoParam opts -> tyargs) = - mkRouteConsOpts' - where - -- th-abstraction does cover this but the version it was introduced in - -- isn't always available - tyvarbndr = +-- 'NestedDiscovery' is chosen when any of the following hold: +-- +-- * The site has /no/ type parameters ('hasTyArgs' is 'False', e.g. a +-- monomorphic site like @App@). Subroute datatypes then need no type +-- variables, so the machinery is always safe, and this preserves the +-- historical behaviour of monomorphic sites (including splitting nested +-- routes across modules). +-- +-- * Parameterized subroutes were explicitly requested +-- ('setParameterizedSubroute'). The subroute datatypes then carry the +-- parent's type variables so the @ParentSite@ \/ @ParentArgs@ associated +-- types are well-scoped. +-- +-- * We are focusing on a nested route for module-splitting +-- ('setFocusOnNestedRoute'). +-- +-- @since 1.7.0.0 +discoveryMode :: RouteOpts -> TyArgs -> DiscoveryMode +discoveryMode opts tyargs + | not (hasTyArgs tyargs) = NestedDiscovery + | roParameterizedSubroute opts = NestedDiscovery + | isJust (roFocusOnNestedRoute opts) = NestedDiscovery + | otherwise = InlineCompat + +-- | 'PlainTV' across template-haskell versions. @th-abstraction@ covers this, +-- but the version it was introduced in isn't always available — and the +-- 'TyVarBndr' /flag/ type also varies by version, so the result type is +-- CPP-guarded too. Used to build the type-variable binders of generated +-- subroute datatypes. +plainTVCompat :: Name -> #if MIN_VERSION_template_haskell(2,21,0) - (`PlainTV` BndrReq) :: Name -> TyVarBndr BndrVis + TyVarBndr BndrVis #elif MIN_VERSION_template_haskell(2,17,0) - (`PlainTV` ()) :: Name -> TyVarBndr () + TyVarBndr () #else - PlainTV :: Name -> TyVarBndr + TyVarBndr #endif +plainTVCompat = +#if MIN_VERSION_template_haskell(2,21,0) + (`PlainTV` BndrReq) +#elif MIN_VERSION_template_haskell(2,17,0) + (`PlainTV` ()) +#else + PlainTV +#endif - subrouteDecTypeArgs = fmap (tyvarbndr . snd) tyargs +-- | Build the data constructor for a route leaf: @LeafR ty… [multi] [Route Sub]@. +-- Shared by the full-tree ('mkRouteConsOpts') and focused-nested +-- ('mkRenderRouteNestedInstanceOpts') constructor generators, which previously +-- spelled this identically. +leafRouteCon :: Resource Type -> Con +leafRouteCon res = + NormalC (mkName $ resourceName res) + $ map (notStrict,) + $ concat [singles, multi, sub] + where + singles = concatMap toSingle $ resourcePieces res + toSingle Static{} = [] + toSingle (Dynamic typ) = [typ] + multi = maybeToList $ resourceMulti res + sub = + case resourceDispatch res of + Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] + _ -> [] - (inlineDerives, mkSds) = getDerivesFor opts (nullifyWhenNoParam opts cxt) +-- | Build the data constructor for a route parent: @ParentR ty… (ChildR tyargs…)@, +-- whose trailing field is the (possibly type-argument-applied) child route +-- datatype. Shared by the full-tree and focused-nested constructor generators. +parentRouteCon :: String -> [Piece Type] -> TyArgs -> Con +parentRouteCon name pieces tyargs = + NormalC (mkName name) + $ map (notStrict,) + $ singles ++ [applyTyArgs (ConT (mkName name)) tyargs] + where + singles = concatMap toSingle pieces + toSingle Static{} = [] + toSingle (Dynamic typ) = [typ] - mkRouteConsOpts' :: [ResourceTree Type] -> ([Con], [Dec]) - mkRouteConsOpts' = foldMap mkRouteCon +-- | The deriving context for a child\/subroute datatype. The site's instance +-- context only makes sense on a child that actually carries the type +-- arguments; an unparameterized child (the backwards-compatible default) +-- can't, so deriving with that context would leave the variables ambiguous. +-- Nullify the context in that case, mirroring historical Yesod. +childDerivCxt :: TyArgs -> Cxt -> Cxt +childDerivCxt tyargs cxt + | hasTyArgs tyargs = cxt + | otherwise = [] - mkRouteCon (ResourceLeaf res) = - ([con], []) - where - con = NormalC (mkName $ resourceName res) - $ map (notStrict,) - $ concat [singles, multi, sub] - singles = concatMap toSingle $ resourcePieces res - toSingle Static{} = [] - toSingle (Dynamic typ) = [typ] +-- | Generate the constructors of a route data type, with custom +-- 'RouteOpts'. +-- +-- The first element in the return is the list of constructors for the +-- @Route site@ datatype. The second element is the list of 'Dec' to +-- declare nested datatypes or class instances of the 'RenderRouteNested' +-- for those instances. +-- +-- @since 1.6.25.0 +mkRouteConsOpts :: RouteOpts -> Cxt -> TyArgs -> Type -> [ResourceTree Type] -> Q ([Con], [Dec]) +mkRouteConsOpts opts cxt origTyargs master resourceTrees = do + (prePieces, focusedTrees) <- + case roFocusOnNestedRoute opts of + Nothing -> + pure ([], resourceTrees) + Just target -> do + let mnestedRoute = findNestedRoute target resourceTrees + case mnestedRoute of + Nothing -> + fail $ "Target '" <> target <> "' was not found in resources." + Just r -> + pure r + mkRouteConsOpts' prePieces focusedTrees + where + -- When nested route discovery is enabled, child datatypes carry the + -- parent's type variables, because RenderRouteNested has associated type + -- families (ParentSite, ParentArgs) that reference the parent type; + -- without the type variables on the child datatype, they'd be out of + -- scope on the RHS of the type family instance. + -- + -- When it is disabled (the backwards-compatible default), child + -- datatypes are unparameterized (kind 'Type'), matching the historical + -- output. See 'discoveryMode'. Computed once and reused below. + mode = discoveryMode opts origTyargs + tyargs = + case mode of + NestedDiscovery -> origTyargs + InlineCompat -> NoTyArgs + subrouteDecTypeArgs = fmap plainTVCompat (tyArgsBinders tyargs) - multi = maybeToList $ resourceMulti res + -- Derives for the child (subroute) datatypes. See 'childDerivCxt'. + childCxt = childDerivCxt tyargs cxt + (inlineDerives, mkStandaloneDerives) = getDerivesFor opts childCxt - sub = - case resourceDispatch res of - Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] - _ -> [] + mkRouteConsOpts' :: [Piece Type] -> [ResourceTree Type] -> Q ([Con], [Dec]) + mkRouteConsOpts' prePieces trees = do + results <- mapM (mkRouteCon prePieces) trees + pure (mconcat results) - mkRouteCon (ResourceParent name _check pieces children) = - let (cons, decs) = mkRouteConsOpts' children - dec = DataD [] dataName subrouteDecTypeArgs Nothing cons inlineDerives - in ([con], dec : decs ++ mkSds consDataType) + mkRouteCon :: [Piece Type] -> ResourceTree Type -> Q ([Con], [Dec]) + mkRouteCon _ (ResourceLeaf res) = + -- A leaf is always a constructor of the (possibly focused) datatype: + -- in focus mode we have already narrowed @resourceTrees@ to the + -- target's children, so every leaf reached here is a leaf of the + -- focused route. + pure ([leafRouteCon res], []) + + mkRouteCon prePieces (ResourceParent name _check _attrs pieces children) = do + -- Accumulate pieces for children: combine parent pieces with this route's pieces + let accumulatedPieces = prePieces <> pieces + (cons, decs) <- mkRouteConsOpts' accumulatedPieces children + let childDataName = mkName name + + -- Generate the child datatype if it has not been generated + -- already, but only if we are *not* focusing on some other + -- datatype. + mname' <- lookupTypeName name + mdec <- case mname' of + Just _ -> do + -- datatype already exists, definitely don't generate it + pure Nothing + Nothing -> do + let childData = mkChildDataGen childDataName cons inlineDerives + childDataType = applyTyArgs (ConT childDataName) tyargs + case roFocusOnNestedRoute opts of + Just target | target /= name -> + -- If we have a target, and this ain't it, don't + -- generate + pure Nothing + _ | InlineCompat <- mode -> + -- Backwards-compatible default: emit just the + -- (unparameterized) child datatype and its standalone + -- derives. No RenderRouteNested instance; renderRoute + -- inlines the children. + pure $ Just (childData : mkStandaloneDerives childDataType) + _ -> + -- Nested discovery: either `Just target | target == + -- name` (matching a target, and this is it) or + -- `Nothing` (no target, or we already found it). Emit + -- the child datatype plus its RenderRouteNested + -- instance so the parent's renderRoute can delegate. + Just <$> + nestedChildDataAndInstance + opts cxt childCxt tyargs master childDataName cons + (prePieces <> pieces) children + + return ([parentRouteCon name pieces tyargs], maybe id (<>) mdec decs) where - con = NormalC dataName - $ map (notStrict,) - $ singles ++ [consDataType] + mkChildDataGen :: Name -> [Con] -> [DerivClause] -> Dec + mkChildDataGen childDataName cons conts = + DataD [] childDataName subrouteDecTypeArgs Nothing cons conts - singles = concatMap toSingle pieces - toSingle Static{} = [] - toSingle (Dynamic typ) = [typ] +-- | The shared preamble for rendering a 'ResourceParent': fresh names for the +-- parent's dynamic pieces and for the wrapped @child@ route, plus the +-- constructor pattern @Name dyn… child@ binding them. Returns the dynamic +-- names, the child name, and the pattern. +parentConPat :: String -> [Piece a] -> Q ([Name], Name, Pat) +parentConPat name pieces = do + let cnt = length [() | Dynamic{} <- pieces] + dyns <- replicateM cnt $ newName "dyn" + child <- newName "child" + pure (dyns, child, conPCompat (mkName name) $ map VarP $ dyns ++ [child]) - dataName = mkName name - consDataType = foldl' (\b a -> b `AppT` fst a) (ConT dataName) tyargs +-- | Is this path piece a dynamic capture, as opposed to a static segment? +isDynamic :: Piece t -> Bool +isDynamic Dynamic{} = True +isDynamic _ = False --- | Clauses for the 'renderRoute' method. -mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause] -mkRenderRouteClauses = - mapM go +-- | Render a route's path pieces to a list of @Text@-valued expressions, +-- pairing each 'Dynamic' piece with its bound variable in order. Fails the +-- splice if the piece list and the binder list are out of sync (a dynamic +-- piece with no corresponding bound variable). +mkPieces :: (String -> Exp) -> Exp -> [Piece t] -> [Name] -> Q [Exp] +mkPieces _ _ [] _ = pure [] +mkPieces toText tsp (Static s:ps) dyns = (toText s :) <$> mkPieces toText tsp ps dyns +mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = (tsp `AppE` VarE d :) <$> mkPieces toText tsp ps dyns +mkPieces _ _ (Dynamic _ : _) [] = + fail "RenderRoute.mkPieces: a dynamic path piece has no corresponding bound variable (route definition and piece-binder list are out of sync)" + +-- | Clauses for the 'renderRoute' method. This should be called from the +-- instance derivation for 'RenderRoute'. +mkRenderRouteClauses :: RouteOpts -> TyArgs -> [ResourceTree Type] -> Q [Clause] +mkRenderRouteClauses opts origTyargs = + goList where - isDynamic Dynamic{} = True - isDynamic _ = False + goList = fmap mconcat . mapM go - go (ResourceParent name _check pieces children) = do - let cnt = length $ filter isDynamic pieces + mode = discoveryMode opts origTyargs + + go (ResourceParent name _check _attrs pieces children) = + case mode of + -- Opted in to nested discovery: the parent's renderRoute delegates + -- to the child's RenderRouteNested instance. + NestedDiscovery -> goNested + -- Backwards-compatible default: inline the child clauses, + -- prepending this parent's path pieces, exactly as historical + -- Yesod did. + InlineCompat -> goInline + where + goNested = do + (dyns, child, pat) <- parentConPat name pieces + + body <- [| renderRouteNested $(pure (parentArgsExpr dyns)) $(pure (VarE child)) |] + pure [Clause [pat] (NormalB body) []] + + goInline = do + (dyns, child, pat) <- parentConPat name pieces + + pack' <- [|pack|] + tsp <- [|toPathPiece|] + piecesSingle <- mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns + + childRender <- newName "childRender" + childClauses <- goList children + + body <- delegatingBody piecesSingle (VarE childRender) (VarE child) + + pure [Clause [pat] (NormalB body) [FunD childRender childClauses]] + + go (ResourceLeaf res) = do + let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) dyns <- replicateM cnt $ newName "dyn" - child <- newName "child" - let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child] + sub <- + case resourceDispatch res of + Subsite{} -> return <$> newName "sub" + _ -> return [] + let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub pack' <- [|pack|] tsp <- [|toPathPiece|] - let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns + piecesSingle <- mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns - childRender <- newName "childRender" - let rr = VarE childRender - childClauses <- mkRenderRouteClauses children + piecesMulti <- + case resourceMulti res of + Nothing -> return $ ListE [] + Just{} -> do + tmp <- [|toPathMultiPiece|] + return $ tmp `AppE` VarE (last dyns) - a <- newName "a" - b <- newName "b" + body <- + case sub of + [x] -> do + rr <- [|renderRoute|] + delegatingBody piecesSingle rr (VarE x) + _ -> + return $ mkTupE [foldr consE piecesMulti piecesSingle, ListE []] - colon <- [|(:)|] - let cons y ys = InfixE (Just y) colon (Just ys) - let pieces' = foldr cons (VarE a) piecesSingle + return [Clause [pat] (NormalB body) []] - let body = LamE [TupP [VarP a, VarP b]] (TupE -#if MIN_VERSION_template_haskell(2,16,0) - $ map Just -#endif - [pieces', VarE b] - ) `AppE` (rr `AppE` VarE child) +-- | Build a renderRoute body that delegates its tail to another render +-- function — either a nested child's @renderRouteNested@ (the inline +-- 'ResourceParent' arm) or an embedded subsite's @renderRoute@ (the +-- 'ResourceLeaf' subsite arm). The path-piece list passed in is prepended to +-- the delegate's path list (callers include any parent pieces themselves) and +-- the query string is threaded through unchanged. +delegatingBody + :: [Exp] -- ^ this route's own path pieces (already including any parent pieces) + -> Exp -- ^ the delegate render function + -> Exp -- ^ the child/subsite route argument to render + -> Q Exp +delegatingBody piecesSingle rr childArg = do + a <- newName "a" + b <- newName "b" + let pieces' = foldr consE (VarE a) piecesSingle + [e| ( \ ( $(varP a), $(varP b) ) -> ( $(pure pieces'), $(varE b) ) ) + ( $(pure rr) $(pure childArg) ) + |] - return $ Clause [pat] (NormalB body) [FunD childRender childClauses] +-- | Like 'mkRenderRouteClauses', but instead generates clauses for the +-- definition of 'renderRouteNested'. +-- +-- @since 1.7.0.0 +mkRenderRouteNestedClauses + :: [Either String Name] + -- ^ Either the static path piece or the names of the tuple of the parent arg. + -- + -- These are both necessary to re-synthesize the total route. + -> [ResourceTree Type] + -> Q [Clause] +mkRenderRouteNestedClauses parentArgsNames resources = do + fmap mconcat . mapM go $ resources + where + go (ResourceParent name _check _attrs pieces _children) = do + (dyns, child, pat) <- parentConPat name pieces + -- Extract parent dynamic variables from parentArgsNames + let parentDyns = mapMaybe (either (const Nothing) Just) parentArgsNames + + -- Accumulate parent args: combine parent dynamic vars with this route's dynamic vars + let allDyns = parentDyns ++ dyns + accumulatedParentArgsExp = parentArgsExpr allDyns + + -- The body should call renderRouteNested with accumulated parent args + body <- [| renderRouteNested $(pure accumulatedParentArgsExp) $(pure (VarE child)) |] + pure [Clause [parentArgsPat parentDyns, pat] (NormalB body) []] + go (ResourceLeaf res) = do let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) dyns <- replicateM cnt $ newName "dyn" @@ -221,8 +627,16 @@ pack' <- [|pack|] tsp <- [|toPathPiece|] - let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns + -- Build the FULL path including parent pieces + -- parentArgsNames contains Either String Name for each piece in the parent path + let parentDyns = mapMaybe (either (const Nothing) Just) parentArgsNames + + -- Build parent path pieces from parentArgsNames + parentPieces <- mkParentPieces pack' tsp parentArgsNames parentDyns + -- Build this resource's own pieces + thisResourcePieces <- mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns + piecesMulti <- case resourceMulti res of Nothing -> return $ ListE [] @@ -234,35 +648,62 @@ case sub of [x] -> do rr <- [|renderRoute|] - a <- newName "a" - b <- newName "b" - - colon <- [|(:)|] - let cons y ys = InfixE (Just y) colon (Just ys) - let pieces = foldr cons (VarE a) piecesSingle - - return $ LamE [TupP [VarP a, VarP b]] (TupE -#if MIN_VERSION_template_haskell(2,16,0) - $ map Just -#endif - [pieces, VarE b] - ) `AppE` (rr `AppE` VarE x) + -- Combine parent pieces with this resource's pieces + delegatingBody (parentPieces ++ thisResourcePieces) rr (VarE x) _ -> do colon <- [|(:)|] let cons a b = InfixE (Just a) colon (Just b) - return $ TupE -#if MIN_VERSION_template_haskell(2,16,0) - $ map Just -#endif - [foldr cons piecesMulti piecesSingle, ListE []] + -- Combine parent pieces with this resource's pieces + let allPieces = parentPieces ++ thisResourcePieces + return $ mkTupE [foldr cons piecesMulti allPieces, ListE []] - return $ Clause [pat] (NormalB body) [] + return [Clause [parentArgsPat parentDyns, pat] (NormalB body) []] - mkPieces _ _ [] _ = [] - mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns - mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns - mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120" + -- Build path pieces from parentArgsNames (which contains both static and dynamic pieces) + mkParentPieces :: Exp -> Exp -> [Either String Name] -> [Name] -> Q [Exp] + mkParentPieces pack' tsp parentArgsNames' parentDyns = goParentPieces parentArgsNames' parentDyns + where + goParentPieces [] _ = pure [] + goParentPieces (Left staticStr : rest) dyns = + ((pack' `AppE` LitE (StringL staticStr)) :) <$> goParentPieces rest dyns + goParentPieces (Right _ : rest) (dyn : dyns) = + ((tsp `AppE` VarE dyn) :) <$> goParentPieces rest dyns + goParentPieces (Right _ : _) [] = + fail "RenderRoute.mkParentPieces: a dynamic parent path piece has no corresponding bound variable" +-- | The shared core of every 'RenderRouteNested' instance body. From a parent +-- route's accumulated path pieces and its child resources it computes the +-- @ParentArgs@ tuple 'Type' and the @renderRouteNested@ method clauses. The +-- three instance-emitting sites (the inline child datatype in +-- 'mkRenderRouteInstanceOpts', the focused target in +-- 'mkRenderRouteNestedInstanceOpts', and that target's nested children) differ +-- only in the instance head, the @ParentSite@ right-hand side, and the context +-- they wrap around this — so only those wrappers remain at the call sites, and +-- the piece-naming\/clause-building boilerplate (including the dynamic-binder +-- name derivation) lives here once. +renderRouteNestedBody + :: [Piece Type] -- ^ accumulated parent path pieces + -> [ResourceTree Type] -- ^ child resources + -> Q (Type, [Clause]) -- ^ (ParentArgs tuple type, renderRouteNested clauses) +renderRouteNestedBody prepieces children = do + let piecesAndNames = + map (\p -> case p of + Static str -> Left str + Dynamic a -> Right a) + prepieces + preDyns = mapMaybe (either (const Nothing) Just) piecesAndNames + let parentDynT = parentArgsType preDyns + parentNames <- forM piecesAndNames $ \epiece'name -> + case epiece'name of + Left piece -> pure (Left piece) + Right t -> + case filter isAlphaNum (show t) of + (a : as) -> Right <$> newName (toLower a : as) + [] -> fail + "renderRouteNested: a dynamic piece's type renders with no alphanumeric characters, so no binder name can be derived from it" + childClauses <- mkRenderRouteNestedClauses parentNames children + pure (parentDynT, childClauses) + -- | Generate the 'RenderRoute' instance. -- -- This includes both the 'Route' associated type and the @@ -270,25 +711,53 @@ -- 'mkRenderRouteClauses'. -- -- @since 1.6.25.0 -mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> [(Type, Name)] -> Type -> [ResourceTree Type] -> Q [Dec] +mkRenderRouteInstanceOpts + :: RouteOpts + -> Cxt + -- ^ The context passed around for the instances + -> TyArgs + -- ^ Type arguments + -> Type + -- ^ The type of the foundation resource + -> [ResourceTree Type] + -- ^ The actual tree of routes to generate code for + -> Q [Dec] mkRenderRouteInstanceOpts opts cxt tyargs typ ress = do - cls <- mkRenderRouteClauses ress - let (cons, decs) = mkRouteConsOpts opts cxt tyargs ress - let did = DataInstD [] + case roFocusOnNestedRoute opts of + Nothing -> do + cls <- mkRenderRouteClauses opts tyargs ress + (cons, decs) <- mkRouteConsOpts opts cxt tyargs typ ress + let did = DataInstD [] #if MIN_VERSION_template_haskell(2,15,0) - Nothing routeDataName + Nothing routeDataName #else - ''Route [typ] + ''Route [typ] #endif - Nothing cons inlineDerives - return $ instanceD cxt (ConT ''RenderRoute `AppT` typ) - [ did - , FunD (mkName "renderRoute") cls - ] - : mkSds routeDataName ++ decs + Nothing cons inlineDerives + -- ToParentRoute instances are only needed by the nested-discovery + -- machinery; the backwards-compatible default emits none. + parentRouteInstancesDecs <- + case discoveryMode opts tyargs of + NestedDiscovery -> mkToParentRouteInstances cxt tyargs ress + InlineCompat -> pure [] + pure $ mconcat + [ pure $ instanceD cxt (ConT ''RenderRoute `AppT` typ) + [ did + , FunD 'renderRoute cls + ] + , mkStandaloneDerives routeDataName + , decs + , parentRouteInstancesDecs + ] + Just target -> + case findNestedRoute target ress of + Nothing -> + fail $ "Target '" <> target <> "' was not found in resources." + Just (prepieces, ress') -> + mkRenderRouteNestedInstanceOpts opts cxt tyargs typ prepieces target ress' where routeDataName = ConT ''Route `AppT` typ - (inlineDerives, mkSds) = getDerivesFor opts cxt + (inlineDerives, mkStandaloneDerives) = getDerivesFor opts cxt -- | Get the simple derivation clauses and the standalone derivation clauses -- for a given type and context. @@ -297,20 +766,214 @@ -- clauses. Else, we produce basic deriving clauses for a declaration. getDerivesFor :: RouteOpts -> Cxt -> ([DerivClause], Type -> [Dec]) getDerivesFor opts cxt - | null cxt = ([DerivClause Nothing clazzes'], const []) - | otherwise = ([], \typ -> fmap (StandaloneDerivD Nothing cxt . (`AppT` typ)) clazzes') - where + | null cxt = + ( [DerivClause Nothing clazzes'] + , const [] + ) + | otherwise = + ( [] + , \typ -> fmap (StandaloneDerivD Nothing cxt . (`AppT` typ)) clazzes' + ) + where clazzes' = ConT <$> instanceNamesFromOpts opts +-- | For each datatype, generate an instance of 'ToParentRoute' for the +-- datatype. Instances should mostly look like this: +-- +-- > instance ToParentRoute FooR where +-- > toParentRoute (a0, a1) = FooR a0 a1 +mkToParentRouteInstances :: Cxt -> TyArgs -> [ResourceTree Type] -> Q [Dec] +mkToParentRouteInstances cxt origTyargs ress = do + mconcat <$> mapM (go ([], [])) ress + where + go _ (ResourceLeaf _) = + pure [] + go (accPieces, parentConstructors) (ResourceParent name _check _attrs pieces children) = do + -- Extract dynamic types from accumulated parent pieces + let accDynTypes = [t | Dynamic t <- accPieces] + accDynVars <- mapM (\_ -> newName "parent") accDynTypes + + -- Extract dynamic types from this route's pieces + let piecesDynTypes = [t | Dynamic t <- pieces] + piecesDynVars <- mapM (\_ -> newName "piece") piecesDynTypes + + -- Child route variable + child <- newName "child" + + -- ParentArgs includes BOTH acc and pieces dynamic vars + let allParentDynVars = accDynVars ++ piecesDynVars + + -- Build the full route by applying all parent constructors + -- We need to partition allParentDynVars according to each constructor's piece count + let applyConToParentArgs = buildRouteExpr parentConstructors (mkName name) allParentDynVars (VarE child) + + let toParentRouteD = + FunD 'toParentRoute + [ Clause + [parentArgsPat allParentDynVars, VarP child] + (NormalB applyConToParentArgs) + [] + ] + + let thisInstance = + instanceD cxt (ConT ''ToParentRoute `AppT` applyTypeVariables name) [toParentRouteD] + + -- Accumulate pieces and constructor info for children + let thisPieceCount = length piecesDynTypes + acc' = + ( accPieces <> pieces + , parentConstructors ++ [(mkName name, thisPieceCount)] + ) + + childrenInstances <- mconcat <$> mapM (go acc') children + pure $ thisInstance : childrenInstances + + applyTypeVariables name = + applyTyArgs (ConT (mkName name)) origTyargs + + -- Build the route expression by applying constructors from outermost to innermost + buildRouteExpr :: [(Name, Int)] -> Name -> [Name] -> Exp -> Exp + buildRouteExpr parentCtors thisCtor allDynVars childExpr = + let -- All constructors including this one + thisPieceCount = length allDynVars - sum (map snd parentCtors) + allCtors = parentCtors ++ [(thisCtor, thisPieceCount)] + + -- Partition dynamic vars for each constructor + partitionedVars = go' allDynVars allCtors + where + go' _ [] = [] + go' vars ((_, count) : rest) = + let (varsForThis, remaining) = splitAt count vars + in varsForThis : go' remaining rest + + -- Build expression from inside out using foldr + finalExpr = foldr + (\(ctorName, varsForThis) innerExpr -> + foldl' AppE (ConE ctorName) (map VarE varsForThis ++ [innerExpr])) + childExpr + (zip (map fst allCtors) partitionedVars) + in finalExpr + notStrict :: Bang notStrict = Bang NoSourceUnpackedness NoSourceStrictness -instanceD :: Cxt -> Type -> [Dec] -> Dec -instanceD = InstanceD Nothing +-- | Assemble a @RenderRouteNested@ instance from the pieces that vary between +-- the three sites that emit one (the inline child datatype in +-- 'mkRouteConsOpts', the focused target and its nested children in +-- 'mkRenderRouteNestedInstanceOpts'). The context, child route 'Type', +-- @ParentSite@ right-hand side (the foundation 'Type') and @ParentArgs@ tuple +-- 'Type' plus the @renderRouteNested@ clauses are all that differ; everything +-- else is shared here. +-- +-- @since 1.7.0.0 +mkRenderRouteNestedInstanceD + :: Cxt -- ^ instance context + -> Type -- ^ the child route datatype (instance head argument) + -> Type -- ^ the @ParentSite@ right-hand side (the foundation type) + -> Type -- ^ the @ParentArgs@ tuple type + -> [Clause] -- ^ the @renderRouteNested@ method clauses + -> Dec +mkRenderRouteNestedInstanceD instCxt childRouteType parentSiteRHS parentArgsT clauses = + instanceD + instCxt + (ConT ''RenderRouteNested `AppT` childRouteType) + [ TySynInstD $ TySynEqn Nothing (ConT ''ParentSite `AppT` childRouteType) parentSiteRHS + , TySynInstD $ TySynEqn Nothing (ConT ''ParentArgs `AppT` childRouteType) parentArgsT + , FunD 'renderRouteNested clauses + ] -conPCompat :: Name -> [Pat] -> Pat -conPCompat n pats = ConP n -#if MIN_VERSION_template_haskell(2,18,0) - [] -#endif - pats +-- | Generate the declarations for a nested-discovery /child/ datatype: the +-- (parameterized) datatype declaration, its @RenderRouteNested@ instance, and +-- any standalone deriving clauses. Shared by every nested-discovery +-- constructor generator ('mkRouteConsOpts' and 'mkRenderRouteNestedInstanceOpts') +-- so the datatype shape, instance context, and @ParentSite@\/@ParentArgs@ wiring +-- stay in one place. The focus\/inline gating that decides /whether/ to emit +-- these stays at the call sites, since that differs between them. +-- +-- @since 1.7.0.0 +nestedChildDataAndInstance + :: RouteOpts + -> Cxt -- ^ instance context for the @RenderRouteNested@ instance + -> Cxt -- ^ deriving context for the child datatype (nullified when + -- the child carries no type arguments; see 'mkRouteConsOpts') + -> TyArgs -- ^ type arguments carried by the child datatype + -> Type -- ^ the @ParentSite@ right-hand side (the foundation type) + -> Name -- ^ the child datatype name + -> [Con] -- ^ the child datatype's constructors + -> [Piece Type] -- ^ accumulated parent path pieces for this child + -> [ResourceTree Type] -- ^ the child's own children + -> Q [Dec] +nestedChildDataAndInstance opts instCxt derivCxt tyargs parentSiteRHS childDataName cons accPieces children = do + let subrouteDecTypeArgs = fmap plainTVCompat (tyArgsBinders tyargs) + (inlineDerives, mkStandaloneDerives) = getDerivesFor opts derivCxt + childData = DataD [] childDataName subrouteDecTypeArgs Nothing cons inlineDerives + childDataType = applyTyArgs (ConT childDataName) tyargs + (parentDynT, childClauses) <- renderRouteNestedBody accPieces children + let childInstance = + mkRenderRouteNestedInstanceD instCxt childDataType parentSiteRHS parentDynT childClauses + pure (childData : childInstance : mkStandaloneDerives childDataType) + +mkRenderRouteNestedInstanceOpts + :: RouteOpts + -> Cxt + -> TyArgs + -> Type + -> [Piece Type] + -> String + -> [ResourceTree Type] + -> Q [Dec] +mkRenderRouteNestedInstanceOpts routeOpts cxt tyargs typ prepieces target ress = do + -- Generate constructors for all children + (cons, childDecs) <- mkFocusedChildCons prepieces ress + + let targetName = mkName target + targetDecs = + -- The focused target datatype and its RenderRouteNested instance + -- are emitted through the same shared builder as the in-module + -- and nested-child paths, so the instance context is plain @cxt@ + -- (matching the in-module generator); demanding extra + -- Eq/Show/Read constraints on the site type arguments here would + -- be undischargeable at the delegating RenderRoute instance. + nestedChildDataAndInstance + routeOpts cxt childCxt tyargs typ targetName cons prepieces ress + + -- Return the datatype declaration, instance, and any standalone derives, + -- followed by the declarations for any nested children. + (<> childDecs) <$> targetDecs + where + -- The focused datatype carries the site's type arguments. See 'childDerivCxt'. + childCxt = childDerivCxt tyargs cxt + + -- Generate constructors and nested-instance declarations for the children + -- of the focused target. Structurally similar to 'mkRouteConsOpts'' inner + -- @mkRouteCon@, but deliberately NOT shared: there we are walking the whole + -- site and must honour the focus gate (skip datatypes other than the + -- target) and the InlineCompat branch. Here every tree is already *inside* + -- the focused target, so each parent unconditionally gets its + -- RenderRouteNested instance — applying the focus gate here would wrongly + -- skip grandchild instances. + mkFocusedChildCons :: [Piece Type] -> [ResourceTree Type] -> Q ([Con], [Dec]) + mkFocusedChildCons prePieces trees = + mconcat <$> mapM (mkFocusedChildCon prePieces) trees + + mkFocusedChildCon :: [Piece Type] -> ResourceTree Type -> Q ([Con], [Dec]) + mkFocusedChildCon _ (ResourceLeaf res) = + pure ([leafRouteCon res], []) + + mkFocusedChildCon prePieces (ResourceParent name _check _attrs pieces children) = do + let accumulatedPieces = prePieces <> pieces + (cons, decs) <- mkFocusedChildCons accumulatedPieces children + let childDataName = mkName name + + -- Generate the child datatype and its RenderRouteNested instance unless + -- the datatype already exists (generated by another split-out module). + mname' <- lookupTypeName name + mdec <- case mname' of + Just _ -> pure Nothing + Nothing -> + Just <$> + nestedChildDataAndInstance + routeOpts cxt childCxt tyargs typ childDataName cons + accumulatedPieces children + + return ([parentRouteCon name pieces tyargs], maybe id (<>) mdec decs) diff --git a/src/Yesod/Routes/TH/RouteAttrs.hs b/src/Yesod/Routes/TH/RouteAttrs.hs --- a/src/Yesod/Routes/TH/RouteAttrs.hs +++ b/src/Yesod/Routes/TH/RouteAttrs.hs @@ -1,47 +1,117 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Yesod.Routes.TH.RouteAttrs ( mkRouteAttrsInstance + , mkRouteAttrsInstanceFor + , mkRouteAttrsNestedInstances ) where import Yesod.Routes.TH.Types +import Yesod.Routes.TH.Internal (nestedInstanceExists, resolveRouteCon, instanceD, conPCompat, findNestedRoute) import Yesod.Routes.Class import Language.Haskell.TH.Syntax -import Data.Set (fromList) -import Data.Text (pack) +import Data.Foldable (toList) +import qualified Data.Set as Set +import qualified Data.Text as Text +import Control.Monad mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec mkRouteAttrsInstance cxt typ ress = do - clauses <- mapM (goTree id) ress + clauses <- mapM (goTree Nothing id) ress return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ) - [ FunD 'routeAttrs $ concat clauses + [ FunD 'routeAttrs $ concat clauses ++ + [Clause [ WildP ] (NormalB $ VarE 'mempty) []] ] -goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause] -goTree front (ResourceLeaf res) = return <$> goRes front res -goTree front (ResourceParent name _check pieces trees) = - concat <$> mapM (goTree front') trees +-- | Like 'mkRouteAttrsInstance', but uses a 'String' name of a nested +-- subroute to generate nested instances instead of generating the full +-- instance for all routes. +-- +-- @since 1.7.0.0 +mkRouteAttrsInstanceFor :: Cxt -> Type -> String -> [ResourceTree a] -> Q [Dec] +mkRouteAttrsInstanceFor cxt typ target ress = do + -- Fail loudly (matching Dispatch/RenderRoute/ParseRoute) when the focus + -- target is missing, rather than silently emitting an always-'mempty' + -- 'RouteAttrsNested' instance. + case findNestedRoute target ress of + Nothing -> + fail $ "Target '" ++ target ++ "' was not found in resources." + Just _ -> + pure () + clauses <- mapM (goTree (Just target) id) ress + return [instanceD cxt (ConT ''RouteAttrsNested `AppT` typ) + [ FunD 'routeAttrsNested $ concat clauses ++ + [Clause [ WildP ] (NormalB $ VarE 'mempty) []] + ] + ] + +-- | Generate a 'RouteAttrsNested' instance for every nested parent route in +-- the tree (recursively), skipping any whose instance already exists (e.g. one +-- generated in another module when routes are split). This is the +-- 'RouteAttrs' counterpart to the @RenderRouteNested@ \/ @ParseRouteNested@ \/ +-- @YesodDispatchNested@ instances that a plain 'mkYesod' already emits for its +-- child route fragments, so that @routeAttrsNested ChildR@ resolves for a +-- single-module site just like the other nested-delegation methods do. +-- +-- @since 1.7.0.0 +mkRouteAttrsNestedInstances :: Cxt -> TyArgs -> [ResourceTree a] -> Q [Dec] +mkRouteAttrsNestedInstances cxt tyargs ress = + concat <$> mapM perParent (parentNames ress) where + parentNames trees = concat + [ name : parentNames children + | ResourceParent name _ _ _ children <- trees + ] + perParent name = do + exists <- nestedInstanceExists ''RouteAttrsNested =<< resolveRouteCon name + if exists + then pure [] + else mkRouteAttrsInstanceFor cxt (applyTyArgs (ConT (mkName name)) tyargs) name ress + +goTree :: Maybe String -> (Pat -> Pat) -> ResourceTree a -> Q [Clause] +goTree mtarget front (ResourceLeaf res) = + case mtarget of + Nothing -> + return $ toList $ goRes front res + Just _ -> + return [] +goTree (Just target) front (ResourceParent name _check _attrs _pieces trees) + | target /= name = concat <$> mapM (goTree (Just target) front) trees +goTree mtarget front (ResourceParent name _check _attrs pieces trees) = do + doesNestedInstanceExist <- nestedInstanceExists ''RouteAttrsNested =<< resolveRouteCon name + + if doesNestedInstanceExist + then do + x <- newName "x" + pure [Clause [front (conPCompat (mkName name) (ignored (VarP x)))] (NormalB $ VarE 'routeAttrsNested `AppE` VarE x) []] + else do + -- We only reach this clause when @mtarget@ is 'Nothing' (full + -- instance) or @Just name@ (we found the focus target); clause 2 + -- above peeled off the non-matching @Just other@ case. Either way + -- the remaining subtree is generated unfocused (@Nothing@). The + -- focus target itself is the route boundary, so its own + -- constructor is not prepended (@front@); ordinary parents in the + -- full instance do prepend theirs (@front'@). + let front'' = + if Just name == mtarget + then front + else front' + concat <$> mapM (goTree Nothing front'') trees + where ignored = (replicate toIgnore WildP ++) . return toIgnore = length $ filter isDynamic pieces isDynamic Dynamic{} = True isDynamic Static{} = False - front' = front . ConP (mkName name) -#if MIN_VERSION_template_haskell(2,18,0) - [] -#endif + front' = front . conPCompat (mkName name) . ignored -goRes :: (Pat -> Pat) -> Resource a -> Q Clause -goRes front Resource {..} = +goRes :: (Pat -> Pat) -> Resource a -> Maybe Clause +goRes front Resource {..} = do + guard (not (null resourceAttrs)) return $ Clause [front $ RecP (mkName resourceName) []] - (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs)) + (NormalB $ VarE 'Set.fromList `AppE` ListE (map toText resourceAttrs)) [] where - toText s = VarE 'pack `AppE` LitE (StringL s) - -instanceD :: Cxt -> Type -> [Dec] -> Dec -instanceD = InstanceD Nothing + toText s = VarE 'Text.pack `AppE` LitE (StringL s) diff --git a/src/Yesod/Routes/TH/Types.hs b/src/Yesod/Routes/TH/Types.hs --- a/src/Yesod/Routes/TH/Types.hs +++ b/src/Yesod/Routes/TH/Types.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveLift #-} -- | Warning! This module is considered internal and may have breaking changes @@ -10,6 +12,16 @@ , Dispatch (..) , CheckOverlap , FlatResource (..) + , ParentDetails (..) + -- * Route datatype type arguments + , TyArgs (..) + , toTyArgs + , tyArgsList + , tyArgsTypes + , tyArgsBinders + , tyArgsArity + , hasTyArgs + , applyTyArgs -- ** Helper functions , resourceMulti , resourceTreePieces @@ -18,19 +30,88 @@ ) where import Language.Haskell.TH.Syntax +import Data.List (foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Set (Set) +-- Provides Lift instance for Set in older versions of GHC +import Instances.TH.Lift () +-- | The type arguments of a route datatype, paired with the source 'Name' each +-- was derived from. A monomorphic site like @App@ has 'NoTyArgs'; a +-- parameterized one like @MySub subsite@ has 'SomeTyArgs'. +-- +-- Carrying the (non-)emptiness in the type — rather than as a bare list with a +-- separate @null@ check — keeps \"are there type args?\" and \"what are they?\" +-- a single fact, so the populated branch hands you the 'NonEmpty' directly. +-- +-- @since 1.7.0.0 +data TyArgs + = NoTyArgs + | SomeTyArgs (NonEmpty (Type, Name)) + deriving (Eq, Show) + +-- | Build 'TyArgs' from a list of (type, source-name) pairs. +-- +-- @since 1.7.0.0 +toTyArgs :: [(Type, Name)] -> TyArgs +toTyArgs [] = NoTyArgs +toTyArgs (x : xs) = SomeTyArgs (x :| xs) + +-- | The type arguments as a plain list (empty for 'NoTyArgs'). +-- +-- @since 1.7.0.0 +tyArgsList :: TyArgs -> [(Type, Name)] +tyArgsList NoTyArgs = [] +tyArgsList (SomeTyArgs ne) = NonEmpty.toList ne + +-- | Just the 'Type's of the arguments, in order. +-- +-- @since 1.7.0.0 +tyArgsTypes :: TyArgs -> [Type] +tyArgsTypes = map fst . tyArgsList + +-- | Just the source 'Name's of the arguments, in order. +-- +-- @since 1.7.0.0 +tyArgsBinders :: TyArgs -> [Name] +tyArgsBinders = map snd . tyArgsList + +-- | How many type arguments there are. +-- +-- @since 1.7.0.0 +tyArgsArity :: TyArgs -> Int +tyArgsArity NoTyArgs = 0 +tyArgsArity (SomeTyArgs ne) = NonEmpty.length ne + +-- | Whether there are any type arguments (i.e. the site is parameterized). +-- +-- @since 1.7.0.0 +hasTyArgs :: TyArgs -> Bool +hasTyArgs NoTyArgs = False +hasTyArgs SomeTyArgs {} = True + +-- | Apply the type arguments to a head type (e.g. a route\/subroute type +-- constructor), left to right. This replaces the ad-hoc +-- @'foldl'' 'AppT' con ('fst' '<$>' tyargs)@ that recurred across the +-- generators. +-- +-- @since 1.7.0.0 +applyTyArgs :: Type -> TyArgs -> Type +applyTyArgs t = foldl' AppT t . tyArgsTypes + data ResourceTree typ = ResourceLeaf (Resource typ) - | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ] - deriving (Lift, Show, Functor) + | ResourceParent String CheckOverlap (Set String) [Piece typ] [ResourceTree typ] + deriving (Lift, Show, Functor, Foldable, Traversable) resourceTreePieces :: ResourceTree typ -> [Piece typ] resourceTreePieces (ResourceLeaf r) = resourcePieces r -resourceTreePieces (ResourceParent _ _ x _) = x +resourceTreePieces (ResourceParent _ _ _ x _) = x resourceTreeName :: ResourceTree typ -> String resourceTreeName (ResourceLeaf r) = resourceName r -resourceTreeName (ResourceParent x _ _ _) = x +resourceTreeName (ResourceParent x _ _ _ _) = x data Resource typ = Resource { resourceName :: String @@ -39,16 +120,12 @@ , resourceAttrs :: [String] , resourceCheck :: CheckOverlap } - deriving (Lift, Show, Functor) + deriving (Lift, Show, Functor, Foldable, Traversable) type CheckOverlap = Bool data Piece typ = Static String | Dynamic typ - deriving (Lift, Show) - -instance Functor Piece where - fmap _ (Static s) = Static s - fmap f (Dynamic t) = Dynamic (f t) + deriving (Lift, Show, Functor, Foldable, Traversable) data Dispatch typ = Methods @@ -59,18 +136,25 @@ { subsiteType :: typ , subsiteFunc :: String } - deriving (Lift, Show) - -instance Functor Dispatch where - fmap f (Methods a b) = Methods (fmap f a) b - fmap f (Subsite a b) = Subsite (f a) b + deriving (Lift, Show, Functor, Foldable, Traversable) resourceMulti :: Resource typ -> Maybe typ resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t resourceMulti _ = Nothing +-- | The details of a 'ResourceParent' gathered for a flattened resource: the +-- parent's name, its path pieces, and the route attributes it contributes to +-- its descendants. +-- +-- @since 1.7.0.0 +data ParentDetails a = ParentDetails + { pdName :: String + , pdPieces :: [Piece a] + , pdAttrs :: Set String + } deriving (Show) + data FlatResource a = FlatResource - { frParentPieces :: [(String, [Piece a])] + { frParentDetails :: [ParentDetails a] , frName :: String , frPieces :: [Piece a] , frDispatch :: Dispatch a @@ -81,6 +165,7 @@ flatten = concatMap (go id True) where - go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)] - go front check' (ResourceParent name check pieces children) = - concatMap (go (front . ((name, pieces):)) (check && check')) children + go front check' (ResourceLeaf (Resource a b c _ check)) = + [FlatResource (front []) a b c (check' && check)] + go front check' (ResourceParent name check attrs pieces children) = + concatMap (go (front . ((ParentDetails name pieces attrs):)) (check && check')) children diff --git a/test/Hierarchy.hs b/test/Hierarchy.hs --- a/test/Hierarchy.hs +++ b/test/Hierarchy.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,174 +10,100 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Whole-tree end of the @Hierarchy@ split-codegen fixture: generates the +-- full @RenderRoute@\/@RouteAttrs@\/@ParseRoute@\/@YesodDispatch@ instances for +-- the shared tree (from "Hierarchy.ResourceTree") in one set of splices, and +-- supplies every leaf handler. The @Hierarchy.*@ sibling modules instead each +-- emit one focused nested fragment; importing them here checks the per-fragment +-- and whole-tree codegen agree. Drives the @test-routes@ suite's @hierarchy@ spec. module Hierarchy ( hierarchy - , Dispatcher (..) - , runHandler - , Handler2 - , App - , toText - , Env (..) - , subDispatch -- to avoid warnings , deleteDelete2 , deleteDelete3 + , testRouteDatatype ) where +import Yesod.Core import Test.Hspec import Test.HUnit -import Yesod.Routes.Parse import Yesod.Routes.TH import Yesod.Routes.Class import Language.Haskell.TH.Syntax -import Data.Text (Text, pack, unpack, append) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as S8 +import Data.Text (Text) import qualified Data.Set as Set +import Hierarchy.Admin +import Hierarchy.ResourceTree +import Hierarchy.Nest +import Hierarchy.Nest2 +import Hierarchy.Nest3 +import Hierarchy.Nest2.NestInner -class ToText a where - toText :: a -> Text +-- | Trivial handler synonym kept only for the @deleteDelete2@\/@deleteDelete3@ +-- placeholder handlers below (which exist solely to silence +-- not-in-scope warnings for routes whose handlers are never invoked here). +type Handler site a = a -instance ToText Text where toText = id -instance ToText String where toText = pack +do + fmap concat $ sequence + [ mkRenderRouteInstanceOpts defaultOpts [] NoTyArgs (ConT ''Hierarchy) hierarchyResourcesWithType + , pure <$> mkRouteAttrsInstance [] (ConT ''Hierarchy) hierarchyResourcesWithType + , mkParseRouteInstance NoTyArgs [] (ConT ''Hierarchy) hierarchyResourcesWithType + , mkYesodDispatchOpts defaultOpts "Hierarchy" hierarchyResources + ] -type Handler2 sub master a = a -type Handler site a = Handler2 site site a +instance Yesod Hierarchy -type Request = ([Text], ByteString) -- path info, method -type App sub master = Request -> (Text, Maybe (Route master)) -data Env sub master = Env - { envToMaster :: Route sub -> Route master - , envSub :: sub - , envMaster :: master - } -subDispatch - :: (Env sub master -> App sub master) - -> (Handler2 sub master Text -> Env sub master -> Maybe (Route sub) -> App sub master) - -> (master -> sub) - -> (Route sub -> Route master) - -> Env master master - -> App sub master -subDispatch handler _runHandler getSub toMaster env req = - handler env' req - where - env' = env - { envToMaster = envToMaster env . toMaster - , envSub = getSub $ envMaster env - } - -class Dispatcher sub master where - dispatcher :: Env sub master -> App sub master +getAfter :: HandlerFor site Text +getAfter = pure "after" +getHomeR :: HandlerFor site Text +getHomeR = pure "homer" -runHandler - :: ToText a - => Handler2 sub master a - -> Env sub master - -> Maybe (Route sub) - -> App sub master -runHandler h Env {..} route _ = (toText h, fmap envToMaster route) +getBackwardsR :: Int -> HandlerFor site Text +getBackwardsR _i = pure "backwards" -data Hierarchy = Hierarchy +getGet3 :: HandlerFor site Text +getGet3 = pure "getget3" -do - let resources = [parseRoutes| -/ HomeR GET +postPost3 :: HandlerFor site Text +postPost3 = pure "postPost3" ----------------------------------------- +getNestInnerIndexR :: HandlerFor site Text +getNestInnerIndexR = pure "getNestInnerIndexR" -/!#Int BackwardsR GET +getGetPostR :: HandlerFor site Text +getGetPostR = pure "getGetPostR" -/admin/#Int AdminR: - / AdminRootR GET - /login LoginR GET POST - /table/#Text TableR GET +postGetPostR :: HandlerFor site Text +postGetPostR = pure "postGetPostR" -/nest/ NestR !NestingAttr: +getGet2 :: HandlerFor site Text +getGet2 = pure "getGet2" - /spaces SpacedR GET !NonNested +postPost2 :: HandlerFor site Text +postPost2 = pure "postPost2" - /nest2 Nest2: - / GetPostR GET POST - /get Get2 GET - /post Post2 POST --- /#Int Delete2 DELETE - /nest3 Nest3: - /get Get3 GET - /post Post3 POST --- /#Int Delete3 DELETE +getSpacedR :: HandlerFor site Text +getSpacedR = pure "getSpacedR" -/afterwards AfterR !parent !key=value1: - / After GET !child !key=value2 +getAdminRootR :: Int -> HandlerFor site Text +getAdminRootR _ = pure "getAdminRootR" --- /trailing-nest TrailingNestR: --- /foo TrailingFooR GET --- /#Int TrailingIntR GET -|] +getLoginR :: Int -> HandlerFor site Text +getLoginR _ = pure "getLoginR" - rrinst <- mkRenderRouteInstanceOpts defaultOpts [] [] (ConT ''Hierarchy) $ map (fmap parseType) resources - rainst <- mkRouteAttrsInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources - prinst <- mkParseRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources - dispatch <- mkDispatchClause MkDispatchSettings - { mdsRunHandler = [|runHandler|] - , mdsSubDispatcher = [|subDispatch|] - , mdsGetPathInfo = [|fst|] - , mdsMethod = [|snd|] - , mdsSetPathInfo = [|\p (_, m) -> (p, m)|] - , mds404 = [|pack "404"|] - , mds405 = [|pack "405"|] - , mdsGetHandler = defaultGetHandler - , mdsUnwrapper = return - } resources - return $ - InstanceD - Nothing - [] - (ConT ''Dispatcher - `AppT` ConT ''Hierarchy - `AppT` ConT ''Hierarchy) - [FunD (mkName "dispatcher") [dispatch]] - : prinst - : rainst - : rrinst +postLoginR :: Int -> HandlerFor site Text +postLoginR _ = pure "postLoginR" -getSpacedR :: Handler site String -getSpacedR = "root-leaf" +getTableR :: Int -> Text -> HandlerFor site Text +getTableR _ _ = pure "getTableR" -getGet2 :: Handler site String; getGet2 = "get" -postPost2 :: Handler site String; postPost2 = "post" deleteDelete2 :: Int -> Handler site String; deleteDelete2 = const "delete" -getGet3 :: Handler site String; getGet3 = "get" -postPost3 :: Handler site String; postPost3 = "post" deleteDelete3 :: Int -> Handler site String; deleteDelete3 = const "delete" -getAfter :: Handler site String; getAfter = "after" - -getHomeR :: Handler site String -getHomeR = "home" - -getBackwardsR :: Int -> Handler site Text -getBackwardsR _ = pack "backwards" - -getAdminRootR :: Int -> Handler site Text -getAdminRootR i = pack $ "admin root: " ++ show i - -getLoginR :: Int -> Handler site Text -getLoginR i = pack $ "login: " ++ show i - -postLoginR :: Int -> Handler site Text -postLoginR i = pack $ "post login: " ++ show i - -getTableR :: Int -> Text -> Handler site Text -getTableR _ = append "TableR " - -getGetPostR :: Handler site Text -getGetPostR = pack "get" - -postGetPostR :: Handler site Text -postGetPostR = pack "post" - - hierarchy :: Spec hierarchy = describe "hierarchy" $ do it "nested with spacing" $ @@ -185,33 +112,92 @@ renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], []) it "renders table correctly" $ renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], []) - let disp m ps = dispatcher - (Env - { envToMaster = id - , envMaster = Hierarchy - , envSub = Hierarchy - }) - (map pack ps, S8.pack m) + describe "parseRoute" $ do + let parseNothing = Nothing :: Maybe (Route Hierarchy) + describe "HomeR" $ do + it "works" $ do + parseRoute ([], []) @?= Just HomeR + it "with extraneous query params" $ do + parseRoute ([], [("foo", "bar")]) @?= Just HomeR + describe "AdminR" $ do + it "works" $ do + parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR) + it "fails with extra character" $ do + parseRoute (["admin!", "5"], []) @?= parseNothing + it "works with a subroute with param" $ do + parseRoute (["admin", "6", "table", "hello"], []) @?= Just (AdminR 6 (TableR "hello")) + describe "parseNestedRoute" $ do + it "works" $ do + parseRouteNested ([], []) @?= Just AdminRootR + it "works with param" $ do + parseRouteNested (["table", "hello"], []) @?= Just (TableR "hello") + describe "NestR" $ do + it "fails because there's no top-level handler" $ do + parseRoute (["nest"], []) @?= parseNothing + it "works for SpacedR" $ do + parseRoute (["nest", "spaces"], []) @?= Just (NestR SpacedR) + it "works with parseRouteNested" $ do + parseRouteNested (["spaces"], []) @?= Just SpacedR + describe "Nest2" $ do + it "works" $ do + parseRoute (["nest", "nest2"], []) @?= Just (NestR (Nest2 GetPostR)) + describe "NestInner" $ do + it "works" $ do + parseRoute (["nest", "nest2", "nest-inner"], []) @?= Just (NestR (Nest2 (NestInner NestInnerIndexR))) + describe "parseRouteNested" $ do + describe "NestInner" $ do + it "works" $ do + parseRouteNested ([], []) @?= Just NestInnerIndexR + describe "routeAttrs" $ do + it "inherited attributes" $ do + routeAttrs (NestR SpacedR) @?= Set.fromList ["NestingAttr", "NonNested"] + it "pair attributes" $ + routeAttrs (AfterR After) @?= Set.fromList ["parent", "child", "key=value2"] - let testGetPost route getRes postRes = do - let routeStrs = map unpack $ fst (renderRoute route) - disp "GET" routeStrs @?= (getRes, Just route) - disp "POST" routeStrs @?= (postRes, Just route) + describe "NestingAttr inherits properly" $ do + it "routeAttrs" $ do + routeAttrs (NestR (Nest2 GetPostR)) @?= Set.fromList ["NestingAttr"] + it "routeAttrsNested" $ do + routeAttrsNested GetPostR @?= Set.fromList ["NestingAttr"] + it "routeAttrsNested InnerNest" $ do + routeAttrsNested NestInnerIndexR @?= Set.fromList ["NestingAttr"] - it "dispatches routes with multiple METHODs: admin" $ - testGetPost (AdminR 1 LoginR) "login: 1" "post login: 1" - it "dispatches routes with multiple METHODs: nesting" $ - testGetPost (NestR $ Nest2 GetPostR) "get" "post" +-- This value should compile if all routes are present as expected. +testRouteDatatype :: Route Hierarchy -> Int +testRouteDatatype r = + case r of + HomeR -> 0 + BackwardsR _ -> 1 + AdminR _ sub -> + case sub of + AdminRootR -> 0 + LoginR -> 0 + TableR _ -> 1 + NestR sub -> testNestR sub + -- NOTE: This is a bug in the behavior of the parser. See issue + -- https://github.com/yesodweb/yesod/issues/1886 + -- + -- Nest3, by layout, should be under `NestR`. However, since there + -- is a comment on column 0, this causes the parser to reset the + -- column count. + Nest3 sub -> + case sub of + Get3 -> 0 + Post3 -> 0 + AfterR sub -> + case sub of + After -> 0 - it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR) - it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar") - it "parses" $ do - parseRoute ([], []) @?= Just HomeR - parseRoute ([], [("foo", "bar")]) @?= Just HomeR - parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR) - parseRoute (["admin!", "5"], []) @?= (Nothing :: Maybe (Route Hierarchy)) - it "inherited attributes" $ do - routeAttrs (NestR SpacedR) @?= Set.fromList ["NestingAttr", "NonNested"] - it "pair attributes" $ - routeAttrs (AfterR After) @?= Set.fromList ["parent", "child", "key=value2"] +testNestR :: NestR -> Int +testNestR sub = + case sub of + SpacedR -> 1 + Nest2 sub' -> + case sub' of + GetPostR -> 0 + Get2 -> 0 + Post2 -> 0 + NestInner sub'' -> + case sub'' of + NestInnerIndexR -> 0 diff --git a/test/Hierarchy/Admin.hs b/test/Hierarchy/Admin.hs new file mode 100644 --- /dev/null +++ b/test/Hierarchy/Admin.hs @@ -0,0 +1,29 @@ +{-# language TemplateHaskell, ViewPatterns, OverloadedStrings, TypeFamilies #-} + +-- | @Hierarchy@ split fragment focused on the @AdminR@ parent. Shows the +-- finer-grained helpers — @mkRenderRouteInstanceOpts@ / +-- @mkRouteAttrsInstanceFor@ / @mkParseRouteInstanceFor@ each scoped to +-- @"AdminR"@ — emitting that one fragment's instances against the shared +-- @hierarchyResourcesWithType@ tree, rather than the whole-tree splice in +-- "Hierarchy". +module Hierarchy.Admin where + +import Yesod.Routes.TH +import Hierarchy.ResourceTree +import Language.Haskell.TH +import Data.Text (Text) + +mkRenderRouteInstanceOpts + (setFocusOnNestedRoute "AdminR" defaultOpts) + [] + NoTyArgs + (ConT ''Hierarchy) + hierarchyResourcesWithType +mkRouteAttrsInstanceFor + [] + (ConT ''AdminR) + "AdminR" + $ hierarchyResourcesWithType +mkParseRouteInstanceFor + "AdminR" + $ hierarchyResourcesWithType diff --git a/test/Hierarchy/Nest.hs b/test/Hierarchy/Nest.hs new file mode 100644 --- /dev/null +++ b/test/Hierarchy/Nest.hs @@ -0,0 +1,29 @@ +{-# language TemplateHaskell #-} +{-# language ViewPatterns #-} +{-# language OverloadedStrings #-} +{-# language TypeFamilies #-} + +-- | @Hierarchy@ split fragment focused on the top-level nested parent @NestR@ +-- (which itself contains @Nest2@\/@Nest3@). Uses the canonical +-- @mkYesodDataOpts@ with @setFocusOnNestedRoute "NestR"@ to emit just that +-- fragment's route datatype + render\/attrs\/parse instances — the same +-- higher-level entry point a full Yesod site uses to split route compilation +-- across modules (see @yesod-core\/docs\/split-route-compilation.md@). Imports +-- the deeper @Nest2@\/@Nest3@\/@NestInner@ fragment modules so their +-- separately-emitted instances are in scope for @NestR@ to delegate to. +-- +-- (Sibling fragments "Hierarchy.Admin", "Hierarchy.Nest2" and +-- "Hierarchy.Nest2.NestInner" instead drive the underlying +-- @mkRenderRouteInstanceOpts@ \/ @mkRouteAttrsInstanceFor@ \/ +-- @mkParseRouteInstanceFor@ builders directly, so the route-level generators +-- that @mkYesodDataOpts@ bundles stay covered too.) +module Hierarchy.Nest where + +import Yesod.Routes.TH +import Hierarchy.ResourceTree +import Hierarchy.Nest3 () +import Hierarchy.Nest2 +import Hierarchy.Nest2.NestInner +import Yesod.Core + +mkYesodDataOpts (setFocusOnNestedRoute "NestR" defaultOpts) "Hierarchy" hierarchyResources diff --git a/test/Hierarchy/Nest2.hs b/test/Hierarchy/Nest2.hs new file mode 100644 --- /dev/null +++ b/test/Hierarchy/Nest2.hs @@ -0,0 +1,28 @@ +{-# language TemplateHaskell, OverloadedStrings, ViewPatterns, TypeFamilies #-} + +-- | @Hierarchy@ split fragment focused on the @Nest2@ parent. Emits @Nest2@'s +-- render\/attrs\/parse instances against the shared @hierarchyResourcesWithType@. +-- The top-of-module @do@ block is a compile-time assertion: it calls +-- @parseRouteNested@ for the deeper @NestInner@ fragment (whose instance is +-- emitted in "Hierarchy.Nest2.NestInner") and @fail@s the splice if parsing the +-- empty path does not yield @NestInnerIndexR@ — pinning cross-module nested parse. +module Hierarchy.Nest2 where + +import Yesod.Routes.Class +import Yesod.Routes.TH +import Hierarchy.ResourceTree +import Language.Haskell.TH +import Hierarchy.Nest3 () +import Hierarchy.Nest2.NestInner + +do + let works = parseRouteNested ([], []) :: Maybe NestInner + case works of + Nothing -> + fail "parsing fails" + Just NestInnerIndexR -> + pure [] + +mkRenderRouteInstanceOpts (setFocusOnNestedRoute "Nest2" defaultOpts) [] NoTyArgs (ConT ''Hierarchy) hierarchyResourcesWithType +mkRouteAttrsInstanceFor [] (ConT ''Nest2) "Nest2" $ hierarchyResourcesWithType +mkParseRouteInstanceFor "Nest2" $ hierarchyResourcesWithType diff --git a/test/Hierarchy/Nest2/NestInner.hs b/test/Hierarchy/Nest2/NestInner.hs new file mode 100644 --- /dev/null +++ b/test/Hierarchy/Nest2/NestInner.hs @@ -0,0 +1,23 @@ +{-# language TemplateHaskell #-} +{-# language ViewPatterns, OverloadedStrings #-} +{-# language TypeFamilies #-} + +-- | @Hierarchy@ split fragment focused on the deepest nested parent +-- @NestInner@ (under @NestR@ > @Nest2@). Emits its render\/attrs\/parse +-- instances via @setFocusOnNestedRoute "NestInner"@ + the @*For@ helpers; the +-- @ParseRouteNested NestInner@ instance is what "Hierarchy.Nest2" asserts +-- against at compile time. +module Hierarchy.Nest2.NestInner where + +import Yesod.Routes.TH +import Hierarchy.ResourceTree +import Language.Haskell.TH + +mkRenderRouteInstanceOpts + (setFocusOnNestedRoute "NestInner" defaultOpts) + [] + NoTyArgs + (ConT ''Hierarchy) + hierarchyResourcesWithType +mkRouteAttrsInstanceFor [] (ConT ''NestInner) "NestInner" $ hierarchyResourcesWithType +mkParseRouteInstanceFor "NestInner" $ hierarchyResourcesWithType diff --git a/test/Hierarchy/Nest3.hs b/test/Hierarchy/Nest3.hs new file mode 100644 --- /dev/null +++ b/test/Hierarchy/Nest3.hs @@ -0,0 +1,16 @@ +{-# language TemplateHaskell #-} +{-# language ViewPatterns #-} +{-# language OverloadedStrings #-} +{-# language TypeFamilies #-} + +-- | @Hierarchy@ split fragment focused on the @Nest3@ parent. Demonstrates +-- @mkYesodDataOpts@ with @setFocusOnNestedRoute "Nest3"@ emitting just that +-- nested fragment's route datatype + instances, separate from the whole-tree +-- splice in "Hierarchy". Shares @hierarchyResources@ from "Hierarchy.ResourceTree". +module Hierarchy.Nest3 where + +import Yesod.Routes.TH +import Hierarchy.ResourceTree +import Yesod.Core + +mkYesodDataOpts (setFocusOnNestedRoute "Nest3" defaultOpts) "Hierarchy" hierarchyResources diff --git a/test/Hierarchy/ResourceTree.hs b/test/Hierarchy/ResourceTree.hs new file mode 100644 --- /dev/null +++ b/test/Hierarchy/ResourceTree.hs @@ -0,0 +1,54 @@ +{-# language TemplateHaskell #-} +{-# language QuasiQuotes #-} + +-- | Shared resource tree + foundation type for the @Hierarchy@ split-codegen +-- fixture. The @Hierarchy.*@ sibling modules each focus on one nested parent +-- (NestR, Nest2, Nest3, NestInner, AdminR) via @setFocusOnNestedRoute@ and emit +-- that fragment's instances separately, while "Hierarchy" itself emits the +-- whole-tree instances; keeping the tree here lets every splice share it +-- without tripping the TH stage restriction. Used by the @test-routes@ suite. +module Hierarchy.ResourceTree where + +import Yesod.Routes.Parse +import Language.Haskell.TH (Type) +import Yesod.Routes.TH + +data Hierarchy = Hierarchy + +hierarchyResources :: [ResourceTree String] +hierarchyResources = [parseRoutes| +/ HomeR GET + +---------------------------------------- + +/!#Int BackwardsR GET + +/admin/#Int AdminR: + / AdminRootR GET + /login LoginR GET POST + /table/#Text TableR GET + +/nest/ NestR !NestingAttr: + + /spaces SpacedR GET !NonNested + + /nest2 Nest2: + / GetPostR GET POST + /get Get2 GET + /post Post2 POST + /nest-inner NestInner: + / NestInnerIndexR GET +-- lol + + /nest3 Nest3: + /get Get3 GET + /post Post3 POST +-- /#Int Delete3 DELETE + +/afterwards AfterR !parent !key=value1: + / After GET !child !key=value2 + +|] + +hierarchyResourcesWithType :: [ResourceTree Type] +hierarchyResourcesWithType = map (fmap parseType) hierarchyResources diff --git a/test/Route/DeepAritySpec.hs b/test/Route/DeepAritySpec.hs new file mode 100644 --- /dev/null +++ b/test/Route/DeepAritySpec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Exercises the reify/'typeArity' path that 'assertNestedSubArity' runs +-- inside 'mkNestedDispatchInstanceWith'\'s recursion — the part the pure +-- 'checkNestedSubArity' unit tests in "Route.SubDispatchAritySpec" can't reach. +-- A 2nd-level-or-deeper nested datatype whose arity doesn't match the site's +-- type-argument count must be caught by the guard's @fail@ (an actionable +-- 'ArityMismatch') rather than slip through to a cryptic kind error in +-- generated code. +module Route.DeepAritySpec (spec) where + +import Test.Hspec +import Language.Haskell.TH (recover) +import Yesod.Routes.TH.Internal + ( assertNestedSubArity + , resolveRouteCon + , typeArity + , ArityCallSite(..) + , SubsiteName(..) + , SubsiteArity(..) + ) +import Route.DeepArityTypes (ParamSite, MatchingDeepR, WrongDeepR) + +-- | The reified arities feeding the guard, extracted at compile time through +-- the same 'typeArity' call 'assertNestedSubArity' makes. +reifiedArities :: (Int, Int, Int) +reifiedArities = + $(do + a <- typeArity ''ParamSite + b <- typeArity ''MatchingDeepR + c <- typeArity ''WrongDeepR + [| (a, b, c) |]) + +-- | 'True' iff the arity guard fired its @fail@ for a (site arity 1) vs. +-- (@WrongDeepR@ arity 0) pairing — i.e. the deep mismatch was caught at the +-- guard rather than escaping into ill-kinded generated code. +wrongArityCaught :: Bool +wrongArityCaught = + $(do + rc <- resolveRouteCon "WrongDeepR" + recover [| True |] $ do + assertNestedSubArity TopLevelCall (SubsiteName "ParamSite") (SubsiteArity 1) rc + [| False |]) + +-- | 'True' iff a matching (arity 1 vs. 1) pairing passes the guard cleanly. +matchingArityOk :: Bool +matchingArityOk = + $(do + rc <- resolveRouteCon "MatchingDeepR" + recover [| False |] $ do + assertNestedSubArity TopLevelCall (SubsiteName "ParamSite") (SubsiteArity 1) rc + [| True |]) + +spec :: Spec +spec = describe "deep nested-route arity guard (reify path)" $ do + it "reifies datatype arities used by the guard" $ + reifiedArities `shouldBe` (1, 1, 0) + it "catches a deep arity mismatch with the actionable guard (not a kind error)" $ + wrongArityCaught `shouldBe` True + it "lets a correctly-parameterized deep nested datatype through" $ + matchingArityOk `shouldBe` True diff --git a/test/Route/DeepArityTypes.hs b/test/Route/DeepArityTypes.hs new file mode 100644 --- /dev/null +++ b/test/Route/DeepArityTypes.hs @@ -0,0 +1,15 @@ +-- | Datatypes for "Route.DeepAritySpec", in their own module so the spec's +-- compile-time splices can 'reify' them — a datatype defined in the same module +-- as a top-level splice is not yet in the type environment at a 'reify'. +module Route.DeepArityTypes + ( ParamSite (..) + , MatchingDeepR (..) + , WrongDeepR (..) + ) where + +-- A parameterized site (arity 1) plus two candidate nested datatypes: one whose +-- arity matches (1) and one whose arity is wrong (0). These stand in for a +-- deeply-nested subroute reached by the dispatch recursion. +data ParamSite a = ParamSite +data MatchingDeepR a = MatchingDeepR +data WrongDeepR = WrongDeepR diff --git a/test/Route/DiscoveryModeSpec.hs b/test/Route/DiscoveryModeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Route/DiscoveryModeSpec.hs @@ -0,0 +1,49 @@ +-- | Unit tests for the 'discoveryMode' classifier. It is a pure, total +-- function but previously had no direct coverage; every behavioural test only +-- exercised it indirectly through generated code. +module Route.DiscoveryModeSpec (spec) where + +import Test.Hspec +import Yesod.Routes.TH.RenderRoute + ( defaultOpts + , setParameterizedSubroute + , setFocusOnNestedRoute + , DiscoveryMode (..) + , discoveryMode + ) +import Yesod.Routes.TH.Types (TyArgs, toTyArgs) +import Language.Haskell.TH (Type (ConT), mkName) + +-- | A site with no type parameters ('hasTyArgs' 'False'). +noArgs :: TyArgs +noArgs = toTyArgs [] + +-- | A site with one type parameter ('hasTyArgs' 'True'). +someArgs :: TyArgs +someArgs = toTyArgs [(ConT (mkName "Int"), mkName "a")] + +spec :: Spec +spec = describe "discoveryMode" $ do + -- Dimension 1: no type args (a monomorphic site is always nested). + it "is NestedDiscovery for a monomorphic site, even with all opts off" $ + discoveryMode defaultOpts noArgs `shouldBe` NestedDiscovery + + -- Dimensions 2/3 off, has type args: the backwards-compatible inline case. + it "is InlineCompat for a parameterized site with default opts" $ + discoveryMode defaultOpts someArgs `shouldBe` InlineCompat + + -- Dimension 2: roParameterizedSubroute in the parameterized case. + it "is NestedDiscovery for a parameterized site when parameterized-subroute is set" $ + discoveryMode (setParameterizedSubroute True defaultOpts) someArgs + `shouldBe` NestedDiscovery + + -- Dimension 3: roFocusOnNestedRoute in the parameterized case. + it "is NestedDiscovery for a parameterized site when focusing on a nested route" $ + discoveryMode (setFocusOnNestedRoute "Target" defaultOpts) someArgs + `shouldBe` NestedDiscovery + + it "stays NestedDiscovery for a monomorphic site with the flags set" $ do + discoveryMode (setParameterizedSubroute True defaultOpts) noArgs + `shouldBe` NestedDiscovery + discoveryMode (setFocusOnNestedRoute "Target" defaultOpts) noArgs + `shouldBe` NestedDiscovery diff --git a/test/Route/FallthroughSpec.hs b/test/Route/FallthroughSpec.hs new file mode 100644 --- /dev/null +++ b/test/Route/FallthroughSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns#-} + + +-- | The nested-route fallthrough contract for a top-level site, generated with +-- @setNestedRouteFallthrough True@. Two same-prefix parents share @\/foo@ +-- (@FirstFooR@ index-only, @SecondFooR@ with deeper children). With fallthrough +-- on, a request missing inside @FirstFooR@ continues to the sibling rather than +-- committing. Asserts at both layers: @parseRoute@ falls through to the right +-- constructor, and a WAI dispatch round-trip (via 'YesodCoreTest.RuntimeHarness') +-- serves the expected handler. +module Route.FallthroughSpec where + +import Network.Wai +import Yesod.Core +import Test.Hspec +import Data.ByteString.Lazy (ByteString) + +import YesodCoreTest.RuntimeHarness (assertRequestRaw) + +data App = App + +do + let resources = [parseRoutesNoCheck| + +/ HomeR +/foo FirstFooR: + / FooIndexR +/foo SecondFooR: + /blah FooBlahR + /baz FooBaz1R: + / FooBazIndexR + /baz FooBaz2R: + /foo FooBaz2FooR + + |] + + let opts = setNestedRouteFallthrough True defaultOpts + mkYesodOpts opts "App" resources + +instance Yesod App where + messageLoggerSource = mempty + +handleFooBlahR :: HandlerFor site String +handleFooBlahR = pure "FooBlahR" + +handleHomeR :: HandlerFor site String +handleHomeR = pure "HomeR" + +handleFooBaz2FooR :: HandlerFor site String +handleFooBaz2FooR = pure "FooBaz2FooR" + +handleFooBazIndexR :: HandlerFor site String +handleFooBazIndexR = pure "FooBazIndexR" + +handleFooIndexR :: HandlerFor site String +handleFooIndexR = pure "FooIndexR" + +spec :: Spec +spec = do + describe "parseRoute" $ do + let routeShouldParse path result = + parseRoute (path, []) `shouldBe` Just result + routeShouldNotParse path = + parseRoute (path, []) `shouldBe` (Nothing :: Maybe (Route App)) + it "matches the first parent without falling through" $ do + routeShouldParse ["foo"] (FirstFooR FooIndexR) + it "can fall through" $ do + routeShouldParse ["foo", "blah"] (SecondFooR FooBlahR) + it "nested fallthrough works too" $ do + routeShouldParse ["foo", "baz", "foo"] (SecondFooR (FooBaz2R FooBaz2FooR)) + it "can fail" $ do + routeShouldNotParse ["asdf"] + + describe "Dispatch" $ do + it "/" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = [] + } + (Just "HomeR") + it "/foo" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = ["foo"] + } + (Just "FooIndexR") + +testRequestIO :: HasCallStack => Int -- ^ http status code + -> Request + -> Maybe ByteString -- ^ expected body + -> IO () +testRequestIO status req mexpected = + assertRequestRaw (toWaiApp App) req status mexpected diff --git a/test/Route/FocusLeafConsSpec.hs b/test/Route/FocusLeafConsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Route/FocusLeafConsSpec.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This module pins the constructor set of the generated @FocusNestR@ +-- datatype exactly, so escalate an incomplete 'describeFocus' to an error. +{-# OPTIONS_GHC -Werror=incomplete-patterns #-} + +-- | Regression test for 'mkRouteConsOpts' in focus (module-split) mode. +-- +-- Previously the focused branch dropped every 'ResourceLeaf' among the +-- target's children (returning @([], [])@ for leaves), so the focused +-- datatype was generated without its leaf constructors. Here we splice a +-- datatype built directly from 'mkRouteConsOpts'' focused output, then assert +-- its constructor set is /exactly/ what we expect via a total 'case': +-- +-- * a /missing/ constructor fails the pattern reference (a name that isn't +-- in scope), and +-- * an /extra/ constructor makes 'describeFocus' non-exhaustive, which +-- @-Werror=incomplete-patterns@ (set above) turns into a compile error. +-- +-- So this module fails to build unless @FocusNestR@ has precisely the two leaf +-- constructors @FocusIndexR@ and @FocusShowR Int@. +module Route.FocusLeafConsSpec (spec) where + +import Test.Hspec +import Language.Haskell.TH +import Yesod.Routes.TH.Types +import Yesod.Routes.TH.RenderRoute + ( mkRouteConsOpts + , defaultOpts + , setFocusOnNestedRoute + ) + +data App = App + +-- | A nested route @FocusNestR@ whose children are two leaves. We build the +-- focused datatype from 'mkRouteConsOpts' and declare it by hand from the +-- returned constructors. +$(do + let leaf name pieces = + ResourceLeaf (Resource name pieces (Methods Nothing ["GET"]) [] True) + parent name pieces = + ResourceParent name True mempty pieces + routes = + [ leaf "FocusHomeR" [] + , parent "FocusNestR" [] + [ leaf "FocusIndexR" [] + , leaf "FocusShowR" [Dynamic (ConT ''Int)] + ] + ] + (cons, _decs) <- + mkRouteConsOpts + (setFocusOnNestedRoute "FocusNestR" defaultOpts) + [] + NoTyArgs + (ConT ''App) + routes + pure [DataD [] (mkName "FocusNestR") [] Nothing cons [DerivClause Nothing [ConT ''Show]]]) + +-- | Total over every constructor of the generated @FocusNestR@. Naming each +-- constructor exactly once is what makes this a complete-set assertion: see +-- the module header for how missing/extra constructors are each rejected at +-- compile time. +describeFocus :: FocusNestR -> String +describeFocus r = case r of + FocusIndexR -> "FocusIndexR" + FocusShowR n -> "FocusShowR " ++ show n + +spec :: Spec +spec = describe "mkRouteConsOpts (focus mode)" $ + it "generates exactly the focused route's leaf constructors" $ do + -- The real assertion is at compile time (see 'describeFocus'); these + -- just exercise the generated constructors. + describeFocus FocusIndexR `shouldBe` "FocusIndexR" + describeFocus (FocusShowR 7) `shouldBe` "FocusShowR 7" diff --git a/test/Route/InlineParseClausesSpec.hs b/test/Route/InlineParseClausesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Route/InlineParseClausesSpec.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | Unit tests for 'buildInlineParseClauses', the pure (effect-free) core of +-- the backwards-compatible inline @parseRoute@ codegen. Because it is pure — +-- it takes a deterministic fresh-name supply instead of 'Q'\'s 'newName' and +-- builds AST directly rather than through quotation brackets — its '[Clause]' +-- output can be asserted on directly, with no splicing, compilation, or +-- 'runQ'. This is the testability win from extracting the pure builder out of +-- 'generateParseRouteClausesInline'. +module Route.InlineParseClausesSpec (spec) where + +import Test.Hspec +import Data.Maybe (catMaybes) +import Language.Haskell.TH +import Web.PathPieces (fromPathPiece) +import Yesod.Routes.TH.Types +import Yesod.Routes.TH.ParseRoute (buildInlineParseClauses) +import Route.PureQ (runPureQ) + +-- | Run the pure builder at the top level (no wrapping), the way +-- 'generateParseRouteClausesInline' invokes it. +run :: ResourceTree Type -> [Clause] +run t = runPureQ (buildInlineParseClauses id t) + +leaf :: String -> [Piece Type] -> Dispatch Type -> ResourceTree Type +leaf name pieces d = ResourceLeaf (Resource name pieces d [] True) + +methods :: [String] -> Dispatch Type +methods = Methods Nothing + +parent :: String -> [Piece Type] -> [ResourceTree Type] -> ResourceTree Type +parent name pieces = ResourceParent name True mempty pieces + +-- | Assert there is exactly one clause and hand it to the continuation. +withOnlyClause :: [Clause] -> (Clause -> Expectation) -> Expectation +withOnlyClause cs k = + case cs of + [c] -> k c + _ -> expectationFailure $ "expected exactly one clause, got " <> show (length cs) + +-- | Variables bound by a @fromPathPiece@ view pattern, descending through the +-- list\/tuple\/constructor patterns the inline builder nests them in. +boundDynVars :: Pat -> [Name] +boundDynVars (ViewP (VarE f) inner) + | f == 'fromPathPiece = simpleVars inner +boundDynVars p = concatMap boundDynVars (subPats p) + +-- | Plain 'VarP' names anywhere within a pattern. +simpleVars :: Pat -> [Name] +simpleVars (VarP n) = [n] +simpleVars p = concatMap simpleVars (subPats p) + +-- | The immediate sub-patterns of a pattern (only the shapes the inline +-- builder produces need handling). +subPats :: Pat -> [Pat] +subPats (TupP ps) = ps +subPats (ListP ps) = ps +subPats (ViewP _ p) = [p] +subPats (ParensP p) = [p] +subPats (BangP p) = [p] +subPats (TildeP p) = [p] +subPats (AsP _ p) = [p] +subPats (SigP p _) = [p] +#if MIN_VERSION_template_haskell(2,18,0) +subPats (ConP _ _ ps) = ps +#else +subPats (ConP _ ps) = ps +#endif +subPats _ = [] + +-- | The variables referenced in an expression. +usedVars :: Exp -> [Name] +usedVars (VarE n) = [n] +usedVars e = concatMap usedVars (subExps e) + +-- | The match alternatives of the top-level expression, when it is a @case@ +-- (the shape a parent's committing clause produces). 'Nothing' otherwise. +caseMatches :: Exp -> Maybe [Match] +caseMatches (CaseE _ ms) = Just ms +caseMatches _ = Nothing + +-- | The body expression of a clause that has no @where@ bindings. +clauseExp :: Clause -> Exp +clauseExp (Clause _ body _) = clauseBodyExp body + +-- | Whether a match alternative is the catch-all @_ -> Nothing@ fallback. +isNothingFallback :: Match -> Bool +isNothingFallback (Match WildP (NormalB (ConE n)) []) = n == 'Nothing +isNothingFallback _ = False + +-- | The immediate sub-expressions of an expression. +subExps :: Exp -> [Exp] +subExps (AppE a b) = [a, b] +subExps (AppTypeE e _) = [e] +subExps (InfixE ma _ mb) = catMaybes [ma, mb] +subExps (UInfixE a b c) = [a, b, c] +subExps (ParensE e) = [e] +subExps (LamE _ e) = [e] +subExps (SigE e _) = [e] +subExps (CondE a b c) = [a, b, c] +subExps (CaseE e ms) = e : [me | Match _ (NormalB me) _ <- ms] +subExps (ListE es) = es +#if MIN_VERSION_template_haskell(2,16,0) +subExps (TupE mes) = catMaybes mes +#else +subExps (TupE es) = es +#endif +subExps _ = [] + +-- | The expression in a clause body (the inline builder emits 'NormalB' for +-- leaves and a single-guard 'GuardedB' under fallthrough). +clauseBodyExp :: Body -> Exp +clauseBodyExp (NormalB e) = e +clauseBodyExp (GuardedB ((_, e) : _)) = e +-- Total on the (unreached) empty-guard case: a var-free sentinel so a stray +-- input fails an assertion locally instead of aborting the whole spec run. +clauseBodyExp (GuardedB []) = ConE '() + +spec :: Spec +spec = describe "buildInlineParseClauses (pure inline parseRoute codegen)" $ do + it "produces one clause for a single static leaf" $ + length (run (leaf "HomeR" [Static "home"] (methods ["GET"]))) `shouldBe` 1 + + it "emits exactly one (committing) clause per parent, matching its prefix once" $ do + -- 1.6 semantics: the parent contributes ONE top-level clause that + -- matches the parent prefix, then cases over its children. It does not + -- expand to one flat clause per descendant leaf (which would re-parse + -- the prefix and let a child miss fall through to a sibling route). + let tree = parent "AdminR" [Static "admin"] + [ leaf "UsersR" [Static "users"] (methods ["GET"]) + , leaf "PostsR" [Static "posts"] (methods ["GET"]) + ] + withOnlyClause (run tree) $ \c -> + case caseMatches (clauseExp c) of + Nothing -> expectationFailure "expected the parent clause body to be a case over children" + -- two children + the committing Nothing fallback + Just ms -> length ms `shouldBe` 3 + + it "ends the parent's case with a Nothing fallback (commit-on-parent-prefix)" $ do + -- This is the heart of the backwards-compat fix: once the parent prefix + -- matches, a child miss must resolve to 'Nothing' (a 404 that agrees + -- with dispatch), NOT fall through to a later top-level route. + let tree = parent "AdminR" [Static "admin"] + [ leaf "UsersR" [Static "users"] (methods ["GET"]) ] + withOnlyClause (run tree) $ \c -> + case caseMatches (clauseExp c) of + Nothing -> expectationFailure "expected the parent clause body to be a case over children" + Just ms -> case reverse ms of + (lastM : _) -> isNothingFallback lastM `shouldBe` True + [] -> expectationFailure "expected at least the Nothing fallback" + + it "commits at each level for deeply-nested parents (nested cases, each Nothing-terminated)" $ do + let tree = parent "AR" [Static "a"] + [ parent "BR" [Static "b"] + [ leaf "CR" [Static "c"] (methods ["GET"]) + , leaf "DR" [Static "d"] (methods ["GET"]) + ] + ] + -- One top-level clause for AR; its case has one child match (BR's + -- committing clause-as-match) plus the Nothing fallback. + withOnlyClause (run tree) $ \c -> + case caseMatches (clauseExp c) of + Nothing -> expectationFailure "expected AR's body to be a case" + Just msA -> do + length msA `shouldBe` 2 + isNothingFallback (last msA) `shouldBe` True + -- The non-fallback alternative is BR's committing match, + -- whose body is itself a case (over CR/DR) ending in Nothing. + case msA of + (Match _ (NormalB innerE) [] : _) -> + case caseMatches innerE of + Nothing -> expectationFailure "expected BR's body to be a case" + Just msB -> do + length msB `shouldBe` 3 -- CR, DR, Nothing + isNothingFallback (last msB) `shouldBe` True + _ -> expectationFailure "unexpected shape for BR's match alternative" + + it "binds a dynamic piece with a fromPathPiece view pattern" $ + withOnlyClause (run (leaf "UserR" [Static "user", Dynamic (ConT ''Int)] (methods ["GET"]))) $ \c -> + pprint c `shouldContain` "fromPathPiece" + + it "uses fromPathMultiPiece for a multipiece leaf" $ + withOnlyClause (run (leaf "FilesR" [Static "files"] (Methods (Just (ConT ''String)) ["GET"]))) $ \c -> + pprint c `shouldContain` "fromPathMultiPiece" + + it "delegates a subsite leaf through parseRoute" $ + withOnlyClause (run (leaf "SubR" [Static "sub"] (Subsite (ConT (mkName "SubSite")) "getSub"))) $ \c -> + pprint c `shouldContain` "parseRoute" + + it "prefixes accumulated parent pieces onto each descendant clause" $ do + -- The parent's static piece must appear in the (single) child clause, + -- alongside the child's own piece — that is what \"inline\" means. + let tree = parent "OrgR" [Static "org", Dynamic (ConT ''Int)] + [ leaf "TeamR" [Static "team"] (methods ["GET"]) ] + withOnlyClause (run tree) $ \c -> do + pprint c `shouldContain` "org" + pprint c `shouldContain` "team" + + it "threads the parent's dynamic binder into the reconstructed route body" $ do + -- A parent with a dynamic piece: its binder must be matched in the path + -- pattern (via 'fromPathPiece') *and* fed back into the reconstructed + -- route in the body. That threading — not merely that the pieces show + -- up textually — is the property the inline arm has to preserve. + let tree = parent "OrgR" [Static "org", Dynamic (ConT ''Int)] + [ leaf "TeamR" [Static "team"] (methods ["GET"]) ] + withOnlyClause (run tree) $ \(Clause pats body _) -> do + let dynVars = concatMap boundDynVars pats + used = usedVars (clauseBodyExp body) + -- Exactly one dynamic piece (the parent's, bound via fromPathPiece) + -- and it is referenced in the reconstructed body — i.e. one 'True'. + -- Empty dynVars gives @[] /= [True]@, so this never passes vacuously. + map (`elem` used) dynVars `shouldBe` [True] diff --git a/test/Route/InstanceProbeSpec.hs b/test/Route/InstanceProbeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Route/InstanceProbeSpec.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Pins the answer to: /can 'isInstance' fail if the route datatype's +-- type parameters remain abstract?/ ('nestedInstanceExists' +-- saturates a resolved datatype with fresh, unannotated 'VarT's via +-- 'fullyApplyType' rather than ground types.) +-- +-- The exercised contract: +-- +-- * Saturation to the datatype's /own/ reified arity keeps the probed head +-- well-kinded, so the probe is a total query — \"could any instance +-- match\" — that returns 'True'\/'False' but never aborts the splice. +-- * It holds even when a parameter is higher-kinded (@(f :: Type -> Type)@): +-- the bare @VarT@ 'fullyApplyType' supplies has its kind inferred from the +-- datatype's declared kind, so the head is still well-kinded. +-- * The arity-0 case (no parameters) degenerates to probing the bare +-- constructor. +-- +-- Each probe runs inside a compile-time splice wrapped in 'recover': if +-- 'isInstance' ever threw (the failure mode guarded against here), the +-- splice would fall through to the 'recover' handler, which 'error's, and the +-- expectation would fail loudly rather than silently. +module Route.InstanceProbeSpec (spec) where + +import Test.Hspec +import Language.Haskell.TH (recover, isInstance, Type (ConT, AppT)) +import Yesod.Routes.TH.Internal (nestedInstanceExists, resolveRouteCon) +import Route.InstanceProbeTypes + ( Probe, HasInst, HasInst2, HasInstInt, NoInst, HK, HKInst, Mono + , ProbePoly, PolyFull, PolyUnapplied, PolyPartial + ) + +spec :: Spec +spec = describe "nestedInstanceExists / fullyApplyType abstract-parameter probe" $ do + it "returns True for an arity-1 datatype that has an instance" $ + $(do + rc <- resolveRouteCon "HasInst" + recover [| error "isInstance crashed on HasInst" |] $ do + b <- nestedInstanceExists ''Probe rc + [| b |]) `shouldBe` True + + it "returns True for an arity-2 datatype with an instance at abstract parameters" $ + $(do + rc <- resolveRouteCon "HasInst2" + recover [| error "isInstance crashed on HasInst2" |] $ do + b <- nestedInstanceExists ''Probe rc + [| b |]) `shouldBe` True + + -- Whether probing the abstract head @HasInstInt a@ finds the concrete + -- @instance Probe (HasInstInt Int)@ depends on the GHC version: GHC 9.0+ + -- 'reifyInstances' returns unifiers (so a bare type variable in the query + -- unifies with @Int@ and the probe reports 'True'), whereas GHC < 9.0 does + -- not return the concrete-argument instance for a type-variable query head + -- (so it reports 'False'). This concrete-argument shape never arises in real + -- codegen — nested-discovery instances are always emitted at fully-abstract + -- parameters (the 'HasInst' case above), which every supported GHC resolves + -- identically — so this case only pins the observed 'reifyInstances' + -- divergence, not a behaviour the codegen relies on. +#if __GLASGOW_HASKELL__ >= 900 + it "returns True when the only instance is at a concrete argument (a unifier counts as could-match)" $ + $(do + rc <- resolveRouteCon "HasInstInt" + recover [| error "isInstance crashed on HasInstInt" |] $ do + b <- nestedInstanceExists ''Probe rc + [| b |]) `shouldBe` True +#else + it "returns False when the only instance is at a concrete argument (GHC < 9.0 reifyInstances does not unify a type-variable query head)" $ + $(do + rc <- resolveRouteCon "HasInstInt" + recover [| error "isInstance crashed on HasInstInt" |] $ do + b <- nestedInstanceExists ''Probe rc + [| b |]) `shouldBe` False +#endif + + it "returns False for an arity-1 datatype with no instance" $ + $(do + rc <- resolveRouteCon "NoInst" + recover [| error "isInstance crashed on NoInst" |] $ do + b <- nestedInstanceExists ''Probe rc + [| b |]) `shouldBe` False + + it "does not crash on a higher-kinded (f :: Type -> Type) parameter with no instance (returns False)" $ + $(do + rc <- resolveRouteCon "HK" + recover [| error "isInstance crashed on HK" |] $ do + b <- nestedInstanceExists ''Probe rc + [| b |]) `shouldBe` False + + it "does not crash on a higher-kinded parameter with an instance (returns True)" $ + $(do + rc <- resolveRouteCon "HKInst" + recover [| error "isInstance crashed on HKInst" |] $ do + b <- nestedInstanceExists ''Probe rc + [| b |]) `shouldBe` True + + it "handles the zero-arity case (bare constructor head) with an instance" $ + $(do + rc <- resolveRouteCon "Mono" + recover [| error "isInstance crashed on Mono" |] $ do + b <- nestedInstanceExists ''Probe rc + [| b |]) `shouldBe` True + + -- Poly-kinded class: lets us represent (and so probe) instances whose head + -- is not fully applied — the shapes a 'Type'-kinded class rejects outright. + it "ProbePoly: returns True for an instance at the fully-applied head" $ + $(do + rc <- resolveRouteCon "PolyFull" + recover [| error "isInstance crashed on PolyFull" |] $ do + b <- nestedInstanceExists ''ProbePoly rc + [| b |]) `shouldBe` True + + it "ProbePoly: returns False when the only instance is at the unapplied constructor (the arity-saturated probe head doesn't match it)" $ + $(do + rc <- resolveRouteCon "PolyUnapplied" + recover [| error "isInstance crashed on PolyUnapplied" |] $ do + b <- nestedInstanceExists ''ProbePoly rc + [| b |]) `shouldBe` False + + it "ProbePoly: returns False when the only instance is at a partially-applied head" $ + $(do + rc <- resolveRouteCon "PolyPartial" + recover [| error "isInstance crashed on PolyPartial" |] $ do + b <- nestedInstanceExists ''ProbePoly rc + [| b |]) `shouldBe` False + + -- Why 'nestedInstanceExists' must saturate to the datatype's *full* arity: + -- the partial instance @ProbePoly (PolyPartial a)@ matches *any* one-argument + -- application of @PolyPartial@. Probing one argument short — at @PolyPartial + -- Int@ (kind Type -> Type) — therefore matches it, while the full-arity head + -- @PolyPartial a b@ (kind Type, what the probe actually uses) does not. So a + -- probe that stopped short would be spuriously fooled by a partial instance; + -- saturating fully is what avoids that. These pin that matching boundary by + -- calling 'isInstance' directly at hand-built heads. + it "isInstance matches the partial instance one argument short (PolyPartial Int)" $ + $(do + recover [| error "isInstance crashed on PolyPartial Int" |] $ do + b <- isInstance ''ProbePoly [ConT ''PolyPartial `AppT` ConT ''Int] + [| b |]) `shouldBe` True + + it "isInstance does not match the partial instance at the full application (PolyPartial Int Int)" $ + $(do + recover [| error "isInstance crashed on PolyPartial Int Int" |] $ do + b <- isInstance ''ProbePoly [ConT ''PolyPartial `AppT` ConT ''Int `AppT` ConT ''Int] + [| b |]) `shouldBe` False + + it "isInstance does not match the unapplied-constructor instance once an argument is applied (PolyUnapplied Int)" $ + $(do + recover [| error "isInstance crashed on PolyUnapplied Int" |] $ do + b <- isInstance ''ProbePoly [ConT ''PolyUnapplied `AppT` ConT ''Int] + [| b |]) `shouldBe` False diff --git a/test/Route/InstanceProbeTypes.hs b/test/Route/InstanceProbeTypes.hs new file mode 100644 --- /dev/null +++ b/test/Route/InstanceProbeTypes.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} + +-- | Datatypes and a stand-in probe class for "Route.InstanceProbeSpec", in +-- their own module so the spec's compile-time splices can 'reify' them — a +-- datatype defined in the same module as a top-level splice is not yet in the +-- type environment at a 'reify' (the same reason "Route.DeepArityTypes" is +-- separate). +-- +-- 'Probe' stands in for any of the real nested-discovery classes +-- (@YesodDispatchNested@, @RenderRouteNested@, …) that 'nestedInstanceExists' +-- probes: those classes aren't visible to the pure @test-routes@ suite, but +-- 'nestedInstanceExists' only ever asks @isInstance klass [head]@, so any +-- single-parameter class with the right instance shape exercises the same +-- code path. +module Route.InstanceProbeTypes + ( Probe + , HasInst (..) + , HasInst2 (..) + , HasInstInt (..) + , NoInst (..) + , HK (..) + , HKInst (..) + , Mono (..) + -- * Poly-kinded probe (under-applied instance heads) + , ProbePoly + , PolyFull (..) + , PolyUnapplied (..) + , PolyPartial (..) + ) where + +import Data.Kind (Type) + +-- | A single-parameter probe class, standing in for the nested-discovery +-- classes 'nestedInstanceExists' checks against. +class Probe a + +-- | Arity-1, kind-'Type' parameter, /with/ a @Probe@ instance — the probe must +-- answer 'True'. The instance is given at a fully abstract parameter, exactly +-- as our codegen emits per-route-datatype instances. +data HasInst a = HasInst +instance Probe (HasInst a) + +-- | Arity-2: 'fullyApplyType' must saturate with /two/ fresh 'VarT's before +-- the head is well-kinded. With an instance at fully abstract parameters the +-- probe answers 'True'. +data HasInst2 a b = HasInst2 +instance Probe (HasInst2 a b) + +-- | Arity-1 whose only instance is at a /concrete/ argument. The probe asks +-- \"could any instance match\". On GHC 9.0+ 'reifyInstances' returns unifiers +-- (not just exact matches), so probing the abstract @HasInstInt a@ finds the +-- @Int@ instance and answers 'True'; on GHC < 9.0 'reifyInstances' does not +-- unify a bare type-variable query head against the concrete instance, so it +-- answers 'False'. (Real codegen never emits instances at concrete arguments, +-- so this divergence does not affect nested discovery; see the matching test in +-- "Route.InstanceProbeSpec".) +-- +-- (Instances at an /under-applied/ constructor — the bare @instance Probe +-- HasInstInt@, or an arity-2 datatype applied to one argument like +-- @instance Probe (HasInst2 a)@ — can't be written against this 'Type'-kinded +-- 'Probe': a head of kind @Type -> Type@ is kind-rejected at its definition +-- site (GHC: \"Expecting one more argument to …; Expected a type, but … has +-- kind @* -> *@\"). To probe those shapes at all they must be made +-- representable by a /poly-kinded/ class; see 'ProbePoly' below.) +data HasInstInt a = HasInstInt +instance Probe (HasInstInt Int) + +-- | Arity-1, kind-'Type' parameter, /without/ a @Probe@ instance — the probe +-- must answer 'False'. +data NoInst a = NoInst + +-- | Arity-1 with a kind-annotated, non-'Type' parameter @(f :: Type -> Type)@ +-- and /no/ instance. The point of this case: 'fullyApplyType' saturates @HK@ +-- with a bare, unannotated @VarT@ whose kind GHC must infer from @HK@'s +-- declared kind. The probe must not crash and must report 'False'. +data HK (f :: Type -> Type) = HK + +-- | As 'HK', but /with/ an instance given at an abstract higher-kinded +-- parameter. The probe must report 'True' without crashing. +data HKInst (f :: Type -> Type) = HKInst +instance Probe (HKInst f) + +-- | Arity-0 (the zero type-parameter case): 'fullyApplyType' applies no +-- arguments, so the probed head is the bare constructor. With an instance the +-- probe answers 'True'. +data Mono = Mono +instance Probe Mono + +-- | A /poly-kinded/ probe class. Unlike 'Probe' (kind @Type -> Constraint@), +-- @ProbePoly@ accepts a head of any kind, which makes the under-applied +-- instance shapes that 'Probe' rejects at their definition site representable — +-- so we can pin down what 'nestedInstanceExists' does when the only instance is +-- at such a head. The probe always saturates the datatype to its /own/ arity +-- (a kind-'Type' head; see 'fullyApplyType'), so these cases also confirm it +-- queries at the fully-applied head specifically. +class ProbePoly (a :: k) + +-- | Poly-kinded class, instance at the /fully-applied/ head (kind 'Type'). +-- Positive control: the probe saturates @PolyFull@ to @PolyFull a@ and matches. +data PolyFull a = PolyFull +instance ProbePoly (PolyFull a) + +-- | Instance at the /unapplied/ arity-1 constructor (head kind @Type -> Type@), +-- representable only because 'ProbePoly' is poly-kinded. The probe saturates to +-- @PolyUnapplied a@ before querying, so the instance at the bare constructor is +-- a different head. +data PolyUnapplied a = PolyUnapplied +instance ProbePoly PolyUnapplied + +-- | Instance at a /partially-applied/ arity-2 constructor (head kind +-- @Type -> Type@). As 'PolyUnapplied', the full-arity probe head +-- @PolyPartial a b@ is a different head from the partial instance @PolyPartial a@. +data PolyPartial a b = PolyPartial +instance ProbePoly (PolyPartial a) diff --git a/test/Route/MissingFocusTargetSpec.hs b/test/Route/MissingFocusTargetSpec.hs new file mode 100644 --- /dev/null +++ b/test/Route/MissingFocusTargetSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Exercises the TH failure paths that fire when a 'setFocusOnNestedRoute' +-- target does not exist in the resource tree. Historically the 'ParseRoute' +-- and 'RouteAttrs' generators silently produced an always-'Nothing' \/ +-- always-'mempty' nested instance for a bogus target, while the 'Dispatch' and +-- 'RenderRoute' generators correctly 'fail'ed. All four are now routed through +-- the shared 'findNestedRoute' lookup and 'fail' with the same message. +-- +-- A 'Q' 'fail' raises its message through 'qReport' rather than carrying it in +-- the thrown value (so 'runQ' just reports @\"Q monad failure\"@), so — as in +-- "Route.DeepAritySpec" — we assert at compile time with 'recover': each +-- generator is run inside a splice against a nonexistent target and must take +-- its @fail@ path (driving 'recover' to its handler). The shared lookup that +-- produces the \"was not found in resources\" message is unit-tested directly +-- via 'findNestedRoute'. +module Route.MissingFocusTargetSpec (spec) where + +import Test.Hspec +import Data.Maybe (isNothing) +import Language.Haskell.TH (recover) + +import Yesod.Routes.TH.Types (resourceTreeName, TyArgs(NoTyArgs)) +import Yesod.Routes.TH.ParseRoute (mkParseRouteInstanceFor) +import Yesod.Routes.TH.RouteAttrs (mkRouteAttrsInstanceFor) +import Yesod.Routes.TH.RenderRoute + (mkRenderRouteInstanceOpts, defaultOpts, setFocusOnNestedRoute) +import Yesod.Routes.TH.Dispatch (mkDispatchInstance) +import Yesod.Routes.TH.Internal (findNestedRoute) +import Route.MissingFocusTargetTypes (sampleTree, bogusType, bogusName) + +-- | 'True' iff the named generator 'fail'ed on the bogus focus target (i.e. +-- 'recover' fell through to its @True@ handler); 'False' if it wrongly produced +-- declarations. Each is forced at compile time so a regression to a silent +-- always-empty instance flips the corresponding boolean. + +parseRouteFailed :: Bool +parseRouteFailed = + $(recover [| True |] $ do + _ <- mkParseRouteInstanceFor bogusName sampleTree + [| False |]) + +routeAttrsFailed :: Bool +routeAttrsFailed = + $(recover [| True |] $ do + _ <- mkRouteAttrsInstanceFor [] bogusType bogusName sampleTree + [| False |]) + +renderRouteFailed :: Bool +renderRouteFailed = + $(recover [| True |] $ do + _ <- mkRenderRouteInstanceOpts + (setFocusOnNestedRoute bogusName defaultOpts) + [] NoTyArgs bogusType sampleTree + [| False |]) + +dispatchFailed :: Bool +dispatchFailed = + $(recover [| True |] $ do + _ <- mkDispatchInstance + (setFocusOnNestedRoute bogusName defaultOpts) + bogusType [] NoTyArgs pure sampleTree + [| False |]) + +spec :: Spec +spec = describe "missing focus target" $ do + describe "fails every nested generator (recover path)" $ do + it "ParseRoute (mkParseRouteInstanceFor)" $ + parseRouteFailed `shouldBe` True + it "RouteAttrs (mkRouteAttrsInstanceFor)" $ + routeAttrsFailed `shouldBe` True + it "RenderRoute (mkRenderRouteInstanceOpts)" $ + renderRouteFailed `shouldBe` True + it "Dispatch (mkDispatchInstance)" $ + dispatchFailed `shouldBe` True + + describe "shared lookup (findNestedRoute)" $ do + it "returns Nothing for a target absent from the tree" $ + isNothing (findNestedRoute bogusName sampleTree) + `shouldBe` True + it "returns the subtree for a target present in the tree" $ + (fmap (map resourceTreeName . snd) (findNestedRoute "ParentR" sampleTree)) + `shouldBe` Just ["ChildR"] diff --git a/test/Route/MissingFocusTargetTypes.hs b/test/Route/MissingFocusTargetTypes.hs new file mode 100644 --- /dev/null +++ b/test/Route/MissingFocusTargetTypes.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Shared fixtures for "Route.MissingFocusTargetSpec". The resource tree and +-- bogus type live here (a separate module) so that the spec can use them inside +-- top-level TH splices without tripping the GHC stage restriction. +module Route.MissingFocusTargetTypes + ( sampleTree + , bogusType + , bogusName + ) where + +import Language.Haskell.TH.Syntax (Type(ConT), mkName) +import Yesod.Routes.TH.Types + +-- A tiny tree with a single real nested parent ("ParentR"). The generators +-- under test are never handed that name; they get 'bogusName', which is absent. +sampleTree :: [ResourceTree Type] +sampleTree = + [ ResourceParent "ParentR" True mempty [Static "parent"] + [ ResourceLeaf $ + Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True + ] + ] + +bogusName :: String +bogusName = "DefinitelyNotARealRouteR" + +bogusType :: Type +bogusType = ConT (mkName bogusName) diff --git a/test/Route/NestedParseClausesSpec.hs b/test/Route/NestedParseClausesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Route/NestedParseClausesSpec.hs @@ -0,0 +1,61 @@ +-- | Unit tests for 'generateParseRouteClause' run in 'PureQ' — the +-- monad-polymorphic (over 'Quote') nested @parseRouteNested@ clause generator. +-- Production runs it in 'Q' (hygienic 'newName'); here we pin its name supply to +-- a deterministic counter so its 'Clause' output — and the set of parent names +-- it requests a 'ParseRouteNested' instance for — can be asserted directly, with +-- no splicing or 'runQ'. This is the payoff of hoisting the @isInstance@ query +-- out of the generator (see 'generateParseRouteClause'). +module Route.NestedParseClausesSpec (spec) where + +import Test.Hspec +import Control.Monad.State.Strict (runStateT) +import qualified Data.Set as Set +import Data.Set (Set) +import Language.Haskell.TH +import Yesod.Routes.TH.Types +import Yesod.Routes.TH.RenderRoute (defaultOpts) +import Yesod.Routes.TH.ParseRoute (generateParseRouteClause) +import Route.PureQ (runPureQ) + +-- | Run the nested clause generator in 'PureQ': deterministic fresh names, pure +-- output. Returns the clause plus the set of parent names it requested a +-- 'ParseRouteNested' instance for. +run :: Set String -> ResourceTree Type -> (Clause, Set String) +run existing t = + runPureQ $ + runStateT (generateParseRouteClause existing defaultOpts t) mempty + +leaf :: String -> [Piece Type] -> Dispatch Type -> ResourceTree Type +leaf name pieces d = ResourceLeaf (Resource name pieces d [] True) + +methods :: [String] -> Dispatch Type +methods = Methods Nothing + +parent :: String -> [Piece Type] -> [ResourceTree Type] -> ResourceTree Type +parent name pieces = ResourceParent name True mempty pieces + +fooParent :: ResourceTree Type +fooParent = + parent "FooR" [Static "foo"] + [ leaf "BarR" [Static "bar"] (methods ["GET"]) ] + +spec :: Spec +spec = describe "generateParseRouteClause (nested parseRoute codegen in PureQ)" $ do + it "records a parent that has no nested instance yet" $ + snd (run mempty fooParent) `shouldBe` Set.singleton "FooR" + + it "does not record a parent that already has a nested instance (hoisted query)" $ + snd (run (Set.singleton "FooR") fooParent) `shouldBe` mempty + + it "delegates a parent clause through parseRouteNested" $ + pprint (fst (run mempty fooParent)) `shouldContain` "parseRouteNested" + + it "records nothing for a bare leaf" $ + snd (run mempty (leaf "BarR" [Static "bar"] (methods ["GET"]))) `shouldBe` mempty + + it "is reproducible: re-running the same tree yields an identical clause (names and all)" $ + -- The PureQ counter resets to 0 each run, so the deterministic binders + -- make the whole Clause '=='. Under Q's 'newName' the uniques would + -- differ between runs — this equality is exactly what going through the + -- pure 'Quote' instance buys the tests. + run mempty fooParent `shouldBe` run mempty fooParent diff --git a/test/Route/PureQ.hs b/test/Route/PureQ.hs new file mode 100644 --- /dev/null +++ b/test/Route/PureQ.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | A pure 'Quote' instance for unit-testing the TH clause builders without +-- 'Q'. The builders are monad-polymorphic over 'Quote' (their only effect is +-- fresh-'Name' generation): production runs them in 'Q' for hygienic 'newName' +-- binders, while these tests run them in 'PureQ', where 'newName' is a +-- deterministic monotonic counter. That makes the generated '[Clause]' AST +-- fully determined and directly comparable — no splicing or 'runQ' needed. +-- +-- The deterministic names use non-hygienic 'mkName', which is fine for +-- pure-inspection tests but would risk shadowing in real splices — hence +-- production stays on 'Q' and only the tests pin the builder's monad to 'PureQ'. +module Route.PureQ + ( PureQ + , runPureQ + ) where + +import Control.Monad.State.Strict (State, evalState, state) +import Language.Haskell.TH.Syntax (Name, mkName) +import Language.Haskell.TH.Syntax.Compat (Quote(..)) + +-- | A pure name supply: 'State' over a monotonic counter. +newtype PureQ a = PureQ (State Int a) + deriving (Functor, Applicative, Monad) + +-- | Run a 'PureQ' computation, starting the counter at @0@. Re-running the same +-- builder therefore yields an identical AST (binders and all). +runPureQ :: PureQ a -> a +runPureQ (PureQ s) = evalState s 0 + +-- | Each 'newName' yields a distinct 'mkName' from the counter, so the builder's +-- output is reproducible and comparable. +instance Quote PureQ where + newName base = PureQ $ state $ \n -> (mkName (base ++ show n), n + 1) diff --git a/test/Route/RenderRouteSpec.hs b/test/Route/RenderRouteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Route/RenderRouteSpec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns#-} + +-- | Behavioural spec for @renderRouteNested@ on a deeply-nested route tree. +-- Pins the contract that rendering a nested leaf reconstructs the /entire/ path +-- from the site root (parent pieces and captures included), not just the leaf's +-- own fragment — the caller supplies the ancestor captures as a tuple. +module Route.RenderRouteSpec where + +import Yesod.Core +import Test.Hspec + +data App = App + +mkYesodData "App" [parseRoutes| + +/foo/#Int FooR: + / FooIndexR + /bar/#String FooBarR: + / FooBarIndexR + /baz FooBarBazR: + /new FooBarBazNewR + /delete/#String FooBarBazDeleteR + /get/#String FooBarBazGetR + + |] + +spec :: Spec +spec = do + describe "renderRouteNested" $ do + it "renders the entire route, not just end fragment" $ do + renderRouteNested (3, "hello") (FooBarBazGetR "asdf") + `shouldBe` + (["foo", "3", "bar", "hello", "baz", "get", "asdf"], []) diff --git a/test/Route/RouteAttrSpec.hs b/test/Route/RouteAttrSpec.hs new file mode 100644 --- /dev/null +++ b/test/Route/RouteAttrSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | Pure spec asserting that route attributes (@!x@) declared on a /nested +-- parent/ are captured in its flattened 'frParentDetails' (@pdAttrs@), not just +-- on leaves. Operates directly on the parsed 'ResourceTree' decision data — no +-- splicing or codegen — so it pins where in the flattened structure parent +-- attrs land. +module Route.RouteAttrSpec (spec) where + +import Yesod.Core +import Test.Hspec +import Yesod.Routes.TH.Types +import Data.Set (Set) +import qualified Data.Set as Set + +routeNoAttributes :: [ResourceTree String] +routeNoAttributes = [parseRoutes| +/one OneR: + /two TwoR: + /three ThreeR: + /four FourR POST + |] + +routeWithAttributes :: [ResourceTree String] +routeWithAttributes = [parseRoutes| +/one OneR: + /two TwoR !x !z: + /three ThreeR !y: + /four FourR POST + |] + +spec :: Spec +spec = do + describe "route attrs present" $ do + it "has no route attrs on parent" $ do + let parentDetails = concat $ frParentDetails <$> flatten routeNoAttributes + let attrs = (\detail -> (pdName detail, pdAttrs detail)) <$> parentDetails + Set.fromList attrs + `shouldBe` + Set.fromList + [ ("OneR", Set.empty) + , ("TwoR", Set.empty) + , ("ThreeR", Set.empty) + ] + it "has route attrs on parent" $ do + let parentDetails = concat $ frParentDetails <$> flatten routeWithAttributes + let attrs = (\detail -> (pdName detail, pdAttrs detail)) <$> parentDetails + Set.fromList attrs + `shouldBe` + Set.fromList + [ ("OneR", Set.empty) + , ("TwoR", Set.fromList ["x", "z"]) + , ("ThreeR", Set.singleton "y") + ] diff --git a/test/Route/SubDispatchAritySpec.hs b/test/Route/SubDispatchAritySpec.hs new file mode 100644 --- /dev/null +++ b/test/Route/SubDispatchAritySpec.hs @@ -0,0 +1,78 @@ +-- | Unit tests for 'checkNestedSubArity', the guard that gives +-- 'mkYesodSubDispatchInstance' an actionable error (instead of a cryptic kind +-- error) when a parameterized subsite is paired with unparameterized nested +-- route datatypes. +module Route.SubDispatchAritySpec (spec) where + +import Test.Hspec +import Yesod.Routes.TH.Internal + ( checkNestedSubArity + , arityMismatchMessage + , ArityCallSite(..) + , ArityMismatch(..) + , SubsiteName(..) + , RouteName(..) + , SubsiteArity(..) + , RouteArity(..) + ) + +-- | The newtype wrappers are positional noise in the tests; this names the +-- call the way the production caller does. 'Nothing' means the arities match; +-- 'Just' carries the rendered mismatch message (phrased for a 'SubsiteCall'). +check :: String -> String -> Int -> Int -> Maybe String +check sub route subArgs routeArity = + fmap (arityMismatchMessage SubsiteCall) $ + checkNestedSubArity + (SubsiteName sub) + (RouteName route) + (SubsiteArity subArgs) + (RouteArity routeArity) + +spec :: Spec +spec = describe "checkNestedSubArity" $ do + it "accepts a monomorphic subsite with an unparameterized nested datatype" $ + check "MySub" "NestedR" 0 0 `shouldBe` Nothing + + it "accepts a parameterized subsite whose nested datatype carries the param" $ + check "MySub" "NestedR" 1 1 `shouldBe` Nothing + + it "rejects when the nested datatype carries more params than the subsite" $ + -- Over-arity leaves the instance head partially applied (kind + -- @Type -> ...@), so this must be rejected, not silently accepted. + case check "MySub" "NestedR" 1 2 of + Nothing -> expectationFailure "expected an arity mismatch" + Just msg -> do + msg `shouldContain` "`NestedR` has 2 type parameter(s)" + msg `shouldContain` "the subsite `MySub` has 1" + + it "rejects a parameterized subsite with an unparameterized nested datatype" $ + check "MySub" "NestedR" 1 0 `shouldBe` Just + (concat + [ "mkYesodSubDispatchInstance: the nested route datatype " + , "`NestedR` has 0 type parameter(s), but the subsite `MySub` " + , "has 1. The subroute datatypes must carry exactly the " + , "subsite's type parameter(s) \8212 generate the subsite's " + , "routes with `mkYesodSubDataOpts (setParameterizedSubroute " + , "True defaultOpts) ...` so a parameterized subsite gets " + , "parameterized subroutes." + ]) + + it "names both types in the error message" $ + case check "MySub" "NestedR" 1 0 of + Nothing -> expectationFailure "expected a mismatch" + Just msg -> do + msg `shouldContain` "MySub" + msg `shouldContain` "NestedR" + + describe "arityMismatchMessage phrasing per call site" $ do + let mismatch = ArityMismatch (SubsiteName "MySub") (RouteName "NestedR") + (SubsiteArity 1) (RouteArity 0) + it "names mkYesodSubDispatchInstance and calls it a subsite for a SubsiteCall" $ do + let msg = arityMismatchMessage SubsiteCall mismatch + msg `shouldContain` "mkYesodSubDispatchInstance" + msg `shouldContain` "subsite" + it "names mkYesod and calls it a site (not a subsite) for a TopLevelCall" $ do + let msg = arityMismatchMessage TopLevelCall mismatch + msg `shouldContain` "mkYesod:" + msg `shouldNotContain` "subsite" + msg `shouldContain` "site" diff --git a/test/RouteSpec.hs b/test/RouteSpec.hs --- a/test/RouteSpec.hs +++ b/test/RouteSpec.hs @@ -11,20 +11,36 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns#-} --- {-# OPTIONS_GHC -ddump-splices #-} +-- | Entry point ('main') for the @test-routes@ suite — the pure-routing tests +-- that need no running site. Aggregates the @Route.*@ specs (fallthrough, +-- render, attrs, the pure decision/codegen specs, arity guards, focus-target +-- lookups, ...) and the @Hierarchy@ fixture, then adds inline RenderRoute / +-- route-parsing / overlap-checking / @parseRouteType@ checks below. + import Test.Hspec import Test.HUnit ((@?=)) -import Data.Text (Text, pack, unpack, singleton) +import Data.Text (Text) import Yesod.Routes.Class hiding (Route) -import qualified Yesod.Routes.Class as YRC -import Yesod.Routes.Parse (parseRoutesFile, parseRoutesNoCheck, parseTypeTree, TypeTree (..)) +import Yesod.Routes.Parse (parseTypeTree, TypeTree (..)) +import Yesod.Core import Yesod.Routes.Overlap (findOverlapNames) import Yesod.Routes.TH hiding (Dispatch) -import Language.Haskell.TH.Syntax import Hierarchy -import qualified Data.ByteString.Char8 as S8 import qualified Data.Set as Set +import qualified Route.FallthroughSpec as FallthroughSpec +import qualified Route.RenderRouteSpec as RenderRouteSpec +import qualified YesodCoreTest.RenderRouteSpec as NestedRenderRouteSpec +import qualified Route.RouteAttrSpec as RouteAttrSpec +import qualified Route.DiscoveryModeSpec as DiscoveryModeSpec +import qualified Route.SubDispatchAritySpec as SubDispatchAritySpec +import qualified Route.DeepAritySpec as DeepAritySpec +import qualified Route.InstanceProbeSpec as InstanceProbeSpec +import qualified Route.InlineParseClausesSpec as InlineParseClausesSpec +import qualified Route.NestedParseClausesSpec as NestedParseClausesSpec +import qualified Route.FocusLeafConsSpec as FocusLeafConsSpec +import qualified Route.MissingFocusTargetSpec as MissingFocusTargetSpec +import qualified Data.Text as Text data MyApp = MyApp @@ -47,180 +63,72 @@ Route MySubParam = ParamRoute Char deriving (Show, Eq, Read) - renderRoute (ParamRoute x) = ([singleton x], []) + renderRoute (ParamRoute x) = ([Text.singleton x], []) instance ParseRoute MySubParam where - parseRoute ([unpack -> [x]], _) = Just $ ParamRoute x + parseRoute ([Text.unpack -> [x]], _) = Just $ ParamRoute x parseRoute _ = Nothing getMySubParam :: MyApp -> Int -> MySubParam getMySubParam _ = MySubParam do - texts <- [t|[Text]|] + texts <- pure "[Text]" let resLeaves = map ResourceLeaf [ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"] True - , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] (Methods Nothing ["GET", "POST"]) [] True + , Resource "BlogPostR" [Static "blog", Dynamic "Text"] (Methods Nothing ["GET", "POST"]) [] True , Resource "WikiR" [Static "wiki"] (Methods (Just texts) []) [] True - , Resource "SubsiteR" [Static "subsite"] (Subsite (ConT ''MySub) "getMySub") [] True - , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] (Subsite (ConT ''MySubParam) "getMySubParam") [] True + , Resource "SubsiteR" [Static "subsite"] (Subsite "MySub" "getMySub") [] True + , Resource "SubparamR" [Static "subparam", Dynamic "Int"] (Subsite "MySubParam" "getMySubParam") [] True ] resParent = ResourceParent "ParentR" True + mempty [ Static "foo" - , Dynamic $ ConT ''Text + , Dynamic "Text" ] [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True ] ress = resParent : resLeaves - rrinst <- mkRenderRouteInstanceOpts defaultOpts [] [] (ConT ''MyApp) ress - rainst <- mkRouteAttrsInstance [] (ConT ''MyApp) ress - prinst <- mkParseRouteInstance [] (ConT ''MyApp) ress - dispatch <- mkDispatchClause MkDispatchSettings - { mdsRunHandler = [|runHandler|] - , mdsSubDispatcher = [|subDispatch dispatcher|] - , mdsGetPathInfo = [|fst|] - , mdsMethod = [|snd|] - , mdsSetPathInfo = [|\p (_, m) -> (p, m)|] - , mds404 = [|pack "404"|] - , mds405 = [|pack "405"|] - , mdsGetHandler = defaultGetHandler - , mdsUnwrapper = return - } ress - return $ - InstanceD - Nothing - [] - (ConT ''Dispatcher - `AppT` ConT ''MyApp - `AppT` ConT ''MyApp) - [FunD (mkName "dispatcher") [dispatch]] - : prinst - : rainst - : rrinst + mkYesod "MyApp" ress -instance Dispatcher MySub master where - dispatcher env (pieces, _method) = - ( pack $ "subsite: " ++ show pieces - , Just $ envToMaster env route - ) - where - route = MySubRoute (pieces, []) +instance YesodSubDispatch MySub MyApp where + yesodSubDispatch _yre = undefined -instance Dispatcher MySubParam master where - dispatcher env (pieces, _method) = - case map unpack pieces of - [[c]] -> - let route = ParamRoute c - toMaster = envToMaster env - MySubParam i = envSub env - in ( pack $ "subparam " ++ show i ++ ' ' : [c] - , Just $ toMaster route - ) - _ -> (pack "404", Nothing) +instance YesodSubDispatch MySubParam MyApp where + yesodSubDispatch _yre = undefined -{- -thDispatchAlias - :: (master ~ MyApp, sub ~ MyApp, handler ~ String, app ~ (String, Maybe (YRC.Route MyApp))) - => master - -> sub - -> (YRC.Route sub -> YRC.Route master) - -> app -- ^ 404 page - -> handler -- ^ 405 page - -> Text -- ^ method - -> [Text] - -> app ---thDispatchAlias = thDispatch -thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 = - case dispatch pieces0 of - Just f -> f master sub toMaster app404 handler405 method0 - Nothing -> app404 - where - dispatch = toDispatch - [ Route [] False $ \pieces -> - case pieces of - [] -> do - Just $ \master' sub' toMaster' _app404' handler405' method -> - let handler = - case Map.lookup method methodsRootR of - Just f -> f - Nothing -> handler405' - in runHandler handler master' sub' RootR toMaster' - _ -> error "Invariant violated" - , Route [D.Static "blog", D.Dynamic] False $ \pieces -> - case pieces of - [_, x2] -> do - y2 <- fromPathPiece x2 - Just $ \master' sub' toMaster' _app404' handler405' method -> - let handler = - case Map.lookup method methodsBlogPostR of - Just f -> f y2 - Nothing -> handler405' - in runHandler handler master' sub' (BlogPostR y2) toMaster' - _ -> error "Invariant violated" - , Route [D.Static "wiki"] True $ \pieces -> - case pieces of - _:x2 -> do - y2 <- fromPathMultiPiece x2 - Just $ \master' sub' toMaster' _app404' _handler405' _method -> - let handler = handleWikiR y2 - in runHandler handler master' sub' (WikiR y2) toMaster' - _ -> error "Invariant violated" - , Route [D.Static "subsite"] True $ \pieces -> - case pieces of - _:x2 -> do - Just $ \master' sub' toMaster' app404' handler405' method -> - dispatcher master' (getMySub sub') (toMaster' . SubsiteR) app404' handler405' method x2 - _ -> error "Invariant violated" - , Route [D.Static "subparam", D.Dynamic] True $ \pieces -> - case pieces of - _:x2:x3 -> do - y2 <- fromPathPiece x2 - Just $ \master' sub' toMaster' app404' handler405' method -> - dispatcher master' (getMySubParam sub' y2) (toMaster' . SubparamR y2) app404' handler405' method x3 - _ -> error "Invariant violated" - ] - methodsRootR = Map.fromList [("GET", getRootR)] - methodsBlogPostR = Map.fromList [("GET", getBlogPostR), ("POST", postBlogPostR)] --} +instance Yesod MyApp where + messageLoggerSource = mempty main :: IO () main = hspec $ do + describe "Route.FallthroughSpec" FallthroughSpec.spec + describe "Route.RenderRouteSpec" RenderRouteSpec.spec + describe "YesodCoreTest.RenderRouteSpec" NestedRenderRouteSpec.spec + describe "Route.RouteAttrSpec" RouteAttrSpec.spec + describe "Route.DiscoveryModeSpec" DiscoveryModeSpec.spec + describe "Route.SubDispatchAritySpec" SubDispatchAritySpec.spec + describe "Route.DeepAritySpec" DeepAritySpec.spec + describe "Route.InstanceProbeSpec" InstanceProbeSpec.spec + describe "Route.InlineParseClausesSpec" InlineParseClausesSpec.spec + describe "Route.NestedParseClausesSpec" NestedParseClausesSpec.spec + describe "Route.FocusLeafConsSpec" FocusLeafConsSpec.spec + describe "Route.MissingFocusTargetSpec" MissingFocusTargetSpec.spec describe "RenderRoute instance" $ do it "renders root correctly" $ renderRoute RootR @?= ([], []) - it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], []) - it "renders wiki correctly" $ renderRoute (WikiR $ map pack ["foo", "bar"]) @?= (map pack ["wiki", "foo", "bar"], []) - it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map pack ["foo", "bar"], [(pack "baz", pack "bin")])) - @?= (map pack ["subsite", "foo", "bar"], [(pack "baz", pack "bin")]) + it "renders blog post correctly" $ renderRoute (BlogPostR $ Text.pack "foo") @?= (map Text.pack ["blog", "foo"], []) + it "renders wiki correctly" $ renderRoute (WikiR $ map Text.pack ["foo", "bar"]) @?= (map Text.pack ["wiki", "foo", "bar"], []) + it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map Text.pack ["foo", "bar"], [(Text.pack "baz", Text.pack "bin")])) + @?= (map Text.pack ["subsite", "foo", "bar"], [(Text.pack "baz", Text.pack "bin")]) it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c') - @?= (map pack ["subparam", "6", "c"], []) + @?= (map Text.pack ["subparam", "6", "c"], []) - describe "thDispatch" $ do - let disp m ps = dispatcher - (Env - { envToMaster = id - , envMaster = MyApp - , envSub = MyApp - }) - (map pack ps, S8.pack m) - it "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR) - it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR) - it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing :: Maybe (YRC.Route MyApp)) - it "routes to blog post" $ disp "GET" ["blog", "somepost"] - @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost") - it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"] - @?= (pack "POST some blog post: somepost2", Just $ BlogPostR $ pack "somepost2") - it "routes to wiki" $ disp "DELETE" ["wiki", "foo", "bar"] - @?= (pack "the wiki: [\"foo\",\"bar\"]", Just $ WikiR $ map pack ["foo", "bar"]) - it "routes to subsite" $ disp "PUT" ["subsite", "baz"] - @?= (pack "subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute ([pack "baz"], [])) - it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"] - @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q') describe "route parsing" $ do it "subsites work" $ do - parseRoute ([pack "subsite", pack "foo"], [(pack "bar", pack "baz")]) @?= - Just (SubsiteR $ MySubRoute ([pack "foo"], [(pack "bar", pack "baz")])) + parseRoute ([Text.pack "subsite", Text.pack "foo"], [(Text.pack "bar", Text.pack "baz")]) @?= + Just (SubsiteR $ MySubRoute ([Text.pack "foo"], [(Text.pack "bar", Text.pack "baz")])) describe "routing table parsing" $ do it "recognizes trailing backslashes as line continuation directives" $ do @@ -314,9 +222,9 @@ findOverlapNames routes @?= [] describe "routeAttrs" $ do it "works" $ do - routeAttrs RootR @?= Set.fromList [pack "foo", pack "bar"] + routeAttrs RootR @?= Set.fromList [Text.pack "foo", Text.pack "bar"] it "hierarchy" $ do - routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child") + routeAttrs (ParentR (Text.pack "ignored") ChildR) @?= Set.singleton (Text.pack "child") hierarchy describe "parseRouteType" $ do let success s t = it s $ parseTypeTree s @?= Just t @@ -333,17 +241,17 @@ success "Foo Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar") success "Foo Bar Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz" -getRootR :: Text -getRootR = pack "this is the root" +getRootR :: HandlerFor site Text +getRootR = pure $ Text.pack "this is the root" -getBlogPostR :: Text -> String -getBlogPostR t = "some blog post: " ++ unpack t +getBlogPostR :: Text -> HandlerFor site String +getBlogPostR t = pure $ "some blog post: " ++ Text.unpack t -postBlogPostR :: Text -> Text -postBlogPostR t = pack $ "POST some blog post: " ++ unpack t +postBlogPostR :: Text -> HandlerFor site Text +postBlogPostR t = pure $ Text.pack $ "POST some blog post: " ++ Text.unpack t -handleWikiR :: [Text] -> String -handleWikiR ts = "the wiki: " ++ show ts +handleWikiR :: [Text] -> HandlerFor site String +handleWikiR ts = pure $ "the wiki: " ++ show ts -getChildR :: Text -> Text -getChildR = id +getChildR :: Text -> HandlerFor site Text +getChildR = pure diff --git a/test/YesodCoreTest.hs b/test/YesodCoreTest.hs --- a/test/YesodCoreTest.hs +++ b/test/YesodCoreTest.hs @@ -11,6 +11,26 @@ import YesodCoreTest.Header import YesodCoreTest.NoOverloadedStrings import YesodCoreTest.SubSub +import YesodCoreTest.SplitSubsite.Runtime (splitSubsiteSpec) +import YesodCoreTest.ParameterizedSubData () +import YesodCoreTest.ParamSubsite.Data () +import YesodCoreTest.ParameterizedSubDispatch () +import qualified YesodCoreTest.ParameterizedSubDispatchRuntime as ParameterizedSubDispatchRuntime +import qualified YesodCoreTest.ParamSubsite.InstanceRuntime as ParamSubsiteInstanceRuntime +import qualified YesodCoreTest.ParamSubsite.SplitRuntime as ParamSubsiteSplitRuntime +import qualified YesodCoreTest.ParamDefaultSplit.Runtime as ParamDefaultSplitRuntime +import qualified YesodCoreTest.ParamTopLevelRuntime as ParamTopLevelRuntime +import qualified YesodCoreTest.ParamFocusSplit.Runtime as ParamFocusSplit +import qualified YesodCoreTest.ParamNoExplicitArgs as ParamNoExplicitArgs +import qualified YesodCoreTest.ParamFallthroughRuntime as ParamFallthroughRuntime +import qualified YesodCoreTest.ParamNoFallthroughRuntime as ParamNoFallthroughRuntime +import qualified YesodCoreTest.ParamNestedNoFallthroughRuntime as ParamNestedNoFallthroughRuntime +import qualified YesodCoreTest.FallthroughMatrix.Runtime as FallthroughMatrixRuntime +import qualified YesodCoreTest.MultiPieceNestedRuntime as MultiPieceNestedRuntime +import qualified YesodCoreTest.ZeroPieceShadowRuntime as ZeroPieceShadowRuntime +import qualified YesodCoreTest.BangSeparatorRuntime as BangSeparatorRuntime +import qualified YesodCoreTest.SubsiteFallthrough.Runtime as SubsiteFallthrough +import qualified YesodCoreTest.SubsiteOptsFallthrough.Runtime as SubsiteOptsFallthrough import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling import YesodCoreTest.Cache @@ -23,6 +43,8 @@ import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json import qualified YesodCoreTest.Content as Content +import qualified YesodCoreTest.NestedDispatch.Runtime as NestedDispatch +import qualified YesodCoreTest.FallthroughDispatch.Runtime as FallthroughDispatch -- Skip on Windows, see https://github.com/yesodweb/yesod/issues/1523#issuecomment-398278450 #ifndef WINDOWS @@ -48,6 +70,7 @@ linksTest noOverloadedTest subSubTest + splitSubsiteSpec internalRequestTest errorHandlingTest cacheTest @@ -72,3 +95,23 @@ breadcrumbTest metaTest Content.specs + describe "NestedDispatch" $ do + NestedDispatch.specs + ParameterizedSubDispatchRuntime.specs + ParamSubsiteInstanceRuntime.specs + ParamSubsiteSplitRuntime.specs + ParamDefaultSplitRuntime.specs + ParamTopLevelRuntime.specs + ParamFocusSplit.specs + ParamNoExplicitArgs.specs + ParamFallthroughRuntime.specs + ParamNoFallthroughRuntime.specs + ParamNestedNoFallthroughRuntime.specs + FallthroughMatrixRuntime.specs + MultiPieceNestedRuntime.specs + ZeroPieceShadowRuntime.specs + BangSeparatorRuntime.specs + SubsiteFallthrough.specs + SubsiteOptsFallthrough.specs + describe "FallthroughDispatch" $ do + FallthroughDispatch.spec diff --git a/test/YesodCoreTest/BangSeparatorRuntime.hs b/test/YesodCoreTest/BangSeparatorRuntime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/BangSeparatorRuntime.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | T2: a @!@-separated dynamic route (@\/!#Int@) is only ever exercised by the +-- render/parse specs (in the @test-routes@ suite's pure-routing @Hierarchy@ +-- fixture). The @!@ flips /compile-time/ overlap checking only, so at runtime +-- @\/!#Int@ dispatches exactly like @\/#Int@. This pins that equivalence with a +-- real WAI round-trip. +module YesodCoreTest.BangSeparatorRuntime + ( specs + ) where + +import Test.Hspec +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text) +import Yesod.Core + +import YesodCoreTest.RuntimeHarness (assertGet) + +data BangApp = BangApp + +mkYesod "BangApp" [parseRoutes| +/!#Int BackwardsR GET +/plain/#Int PlainR GET +|] + +instance Yesod BangApp where + messageLoggerSource = mempty + +getBackwardsR :: Int -> HandlerFor BangApp Text +getBackwardsR i = pure (toPathPiece i <> ":backwards") + +getPlainR :: Int -> HandlerFor BangApp Text +getPlainR i = pure (toPathPiece i <> ":plain") + +req :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO () +req = assertGet BangApp + +specs :: Spec +specs = describe "!-separator dynamic route dispatch (/!#Int)" $ do + it "dispatches BackwardsR on a numeric piece, like a plain /#Int" $ + req 200 ["5"] (Just "5:backwards") + it "still 404s a non-numeric piece (the # parser is unchanged by !)" $ + req 404 ["notanint"] Nothing + it "dispatches the plain /#Int sibling for contrast" $ + req 200 ["plain", "7"] (Just "7:plain") diff --git a/test/YesodCoreTest/FallthroughDispatch/Resources.hs b/test/YesodCoreTest/FallthroughDispatch/Resources.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/FallthroughDispatch/Resources.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Shared route table + foundation type for "YesodCoreTest.FallthroughDispatch.Runtime". +-- Two parents share the @\/foo@ prefix (@FirstFooR@\/@SecondFooR@), plus +-- @\/foo\/#Int@ and @\/foo\/#String@ parents — the deliberate overlap is why it +-- uses @parseRoutesNoCheck@ (the compile-time overlap check would otherwise +-- reject the shared prefix that the fallthrough behaviour exists to handle). +module YesodCoreTest.FallthroughDispatch.Resources where + +import Yesod.Core +import Yesod.Routes.TH.Types + +data App = App + +fallthroughDispatchResources :: [ResourceTree String] +fallthroughDispatchResources = [parseRoutesNoCheck| + +/foo FirstFooR: + / FooIndexR + /neat FooNeatR + +/foo SecondFooR: + / NeverFiresR + /other OtherR + +/foo/#Int ParamFooR: + / FooWithIntR + +/foo/#String TextFooR: + / FooWithTextR +|] diff --git a/test/YesodCoreTest/FallthroughDispatch/Runtime.hs b/test/YesodCoreTest/FallthroughDispatch/Runtime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/FallthroughDispatch/Runtime.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | The single-module fallthrough contract demo for a top-level site, built +-- with @setNestedRouteFallthrough True@. Two same-prefix parents share @\/foo@: +-- @FirstFooR@ (with an index + @\/neat@) and @SecondFooR@ (@\/other@). With +-- fallthrough on, a request that misses inside @FirstFooR@ continues to the +-- sibling @SecondFooR@ instead of committing to @FirstFooR@'s 404 — the WAI +-- specs here pin exactly which parent serves each path. Route table in +-- ".FallthroughDispatch.Resources". +module YesodCoreTest.FallthroughDispatch.Runtime where + +import YesodCoreTest.FallthroughDispatch.Resources +import YesodCoreTest.RuntimeHarness (assertGet) +import Yesod.Core +import Test.Hspec + +mkYesodOpts (setNestedRouteFallthrough True defaultOpts) "App" fallthroughDispatchResources + +instance Yesod App + +handleFooIndexR :: HandlerFor app String +handleFooIndexR = pure "FooIndexR" + +handleOtherR :: HandlerFor app String +handleOtherR = pure "OtherR" + +handleFooNeatR :: HandlerFor app String +handleFooNeatR = pure "FooNeatR" + +handleNeverFiresR :: HandlerFor app String +handleNeverFiresR = pure "NeverFiresR" + +handleFooWithIntR :: Int -> HandlerFor app String +handleFooWithIntR i = pure $ "FooWithIntR " <> show i + +handleFooWithTextR :: String -> HandlerFor app String +handleFooWithTextR str = pure $ "FooWithTextR " <> str + +spec :: Spec +spec = do + describe "FirstFooR" $ do + it "FooIndexR" $ do + assertGet App 200 ["foo"] (Just "FooIndexR") + + it "FooNeatR" $ do + assertGet App 200 ["foo", "neat"] (Just "FooNeatR") + + describe "SecondFooR" $ do + -- This is a little unsatisfying. Ideally we could write a test + -- that expresses that, uh, `renderRoute (SecondFooR NeverFiresR)` + -- would always direct to a different route. Difficult to do + -- though. + it "NeverFiresR" $ do + assertGet App 200 ["foo"] (Just "FooIndexR") + + it "OtherR" $ do + assertGet App 200 ["foo", "other"] (Just "OtherR") + + describe "ParamFooR" $ do + it "FooWithIntR" $ do + assertGet App 200 ["foo", "3"] (Just "FooWithIntR 3") + + describe "TextFooR" $ do + it "FooWithTextR" $ do + assertGet App 200 ["foo", "asdf"] (Just "FooWithTextR asdf") diff --git a/test/YesodCoreTest/FallthroughMatrix/FirstFoo.hs b/test/YesodCoreTest/FallthroughMatrix/FirstFoo.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/FallthroughMatrix/FirstFoo.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | The split-out nested-dispatch instance for @FirstFooR@, generated with the +-- DEFAULT route options — i.e. @fallthrough = False@. The @FooIndexR@\/@FooNeatR@ +-- handlers live ONLY here, so the top module ("YesodCoreTest.FallthroughMatrix.Runtime") can +-- compile only by delegating to the @YesodDispatchNested FirstFooR@ instance +-- generated by this splice (it cannot inline handlers it can't see). +-- +-- This module's flag is @False@, but a nested instance must still report a +-- path miss as 'Nothing' rather than baking a 404 into its own terminal +-- fallback — the fallthrough decision belongs to whichever module delegates +-- to it. An instance that 404s on its own would silently defeat the top +-- module's @fallthrough = True@ intent. +module YesodCoreTest.FallthroughMatrix.FirstFoo where + +import Yesod.Core +import YesodCoreTest.FallthroughMatrix.Resources + +mkYesodOpts (setFocusOnNestedRoute "FirstFooR" defaultOpts) "FMApp" fmResources + +getFooIndexR :: HandlerFor FMApp String +getFooIndexR = pure "FooIndexR" + +getFooNeatR :: HandlerFor FMApp String +getFooNeatR = pure "FooNeatR" diff --git a/test/YesodCoreTest/FallthroughMatrix/Resources.hs b/test/YesodCoreTest/FallthroughMatrix/Resources.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/FallthroughMatrix/Resources.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Shared route table + site type for the cross-module fallthrough matrix. +-- +-- Two parents share the @\/foo@ prefix: @FirstFooR@ (whose nested instance is +-- generated in a /separate/ module, "YesodCoreTest.FallthroughMatrix.FirstFoo", +-- with the default @fallthrough = False@) and @SecondFooR@ (inlined in the +-- top module "YesodCoreTest.FallthroughMatrix.Runtime", which sets +-- @fallthrough = True@). The flag mismatch across the module split is the whole +-- point: it lets us pin who owns the terminal 404 on @\/foo\/other@. +-- +-- @FirstFooR@ owns @\/foo\/neat@ as @GET@-only; @SecondFooR@ owns the same +-- @\/foo\/neat@ path as @POST@-only. This shared @neat@ leaf is what pins the +-- wrong-method contract under fallthrough: a @POST \/foo\/neat@ matches +-- @FirstFooR@'s @GET@ leaf /by path/ and so must commit to 405 — fallthrough is +-- only triggered by a path miss ('Nothing'), and a matched-path/wrong-method +-- leaf returns @Just \<405\>@, never 'Nothing'. If it instead fell through to +-- @SecondFooR@'s @POST@ leaf it would 200, which would be a contract change. +module YesodCoreTest.FallthroughMatrix.Resources where + +import Yesod.Core +import Yesod.Routes.TH.Types + +data FMApp = FMApp + +fmResources :: [ResourceTree String] +fmResources = [parseRoutesNoCheck| +/foo FirstFooR: + / FooIndexR GET + /neat FooNeatR GET + +/foo SecondFooR: + / NeverFiresR GET + /other OtherR GET + /neat NeatPostR POST +|] diff --git a/test/YesodCoreTest/FallthroughMatrix/Runtime.hs b/test/YesodCoreTest/FallthroughMatrix/Runtime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/FallthroughMatrix/Runtime.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Cross-module fallthrough flag mismatch: the delegating module and the +-- split-out nested instance are compiled with opposite fallthrough flags. +-- +-- This top module sets @fallthrough = True@ and delegates @FirstFooR@ to the +-- nested instance generated (with the default @fallthrough = False@) in +-- "YesodCoreTest.FallthroughMatrix.FirstFoo". @SecondFooR@ is inlined here. +-- +-- The single-module analogue "YesodCoreTest.ParamFallthroughRuntime" proves +-- that with fallthrough enabled, @\/foo\/other@ falls through @FirstFooR@ (which +-- has no @other@ child) to @SecondFooR@ → @OtherR@ (200). This module is the +-- same shape but with @FirstFooR@'s instance split into a module compiled with +-- the opposite flag — the configuration that only works because a nested +-- instance reports a path miss as 'Nothing' instead of baking in its own 404, +-- leaving the fallthrough decision to the module that delegates to it. +module YesodCoreTest.FallthroughMatrix.Runtime + ( specs + ) where + +import Test.Hspec +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text) +import Yesod.Core + +import YesodCoreTest.FallthroughMatrix.Resources +import YesodCoreTest.FallthroughMatrix.FirstFoo (FirstFooR(..)) +import YesodCoreTest.RuntimeHarness (assertGet, assertRequestFor) + +mkYesodOpts (setNestedRouteFallthrough True defaultOpts) "FMApp" fmResources + +instance Yesod FMApp where + messageLoggerSource = mempty + +getNeverFiresR :: HandlerFor FMApp String +getNeverFiresR = pure "NeverFiresR" + +getOtherR :: HandlerFor FMApp String +getOtherR = pure "OtherR" + +postNeatPostR :: HandlerFor FMApp String +postNeatPostR = pure "NeatPostR" + +testRequestIO :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO () +testRequestIO = assertGet FMApp + +specs :: Spec +specs = describe "cross-module fallthrough flag mismatch (top True, split child False)" $ do + it "matches the split child's index (FooIndexR at /foo)" $ + testRequestIO 200 ["foo"] (Just "FooIndexR") + it "matches a child of the split parent (FooNeatR at /foo/neat)" $ + testRequestIO 200 ["foo", "neat"] (Just "FooNeatR") + it "falls through the split parent to the inline sibling (OtherR at /foo/other)" $ + -- The headline case. The top module wants fallthrough; FirstFooR has + -- no "other" child, so dispatch falls through to SecondFooR's OtherR + -- (200). If FirstFooR's split instance (compiled with flag False) + -- instead baked a 404 into its own terminal fallback, it would defeat + -- the parent's fallthrough. + testRequestIO 200 ["foo", "other"] (Just "OtherR") + + -- Terminal semantics of fallthrough. Fallthrough is triggered + -- ONLY by a path-level miss (a 'Nothing' from the matched parent): a + -- matched leaf — even one rejecting the method — returns @Just <405>@, so + -- dispatch commits to that leaf and never falls through to a same-prefix + -- sibling. These rows pin both halves of that contract. + describe "wrong method on a matched leaf commits (does not fall through)" $ do + it "POST /foo/neat commits to 405 at FirstFooR's GET leaf" $ + -- FirstFooR owns /foo/neat as GET-only and SecondFooR owns the same + -- /foo/neat path as POST-only. A POST matches FirstFooR's leaf by + -- PATH, so the split (fallthrough=False) FirstFooR instance returns + -- Just <405> — it does NOT return Nothing — and the host's + -- fallthrough arm therefore commits to 405 rather than falling + -- through to SecondFooR's POST leaf (which would be 200). If this + -- ever flips to 200, fallthrough has started swallowing a matched + -- leaf's method rejection, which is a contract change. + assertRequestFor FMApp "POST" 405 ["foo", "neat"] Nothing + it "GET /foo/neat still serves FirstFooR's GET leaf (200)" $ + -- The mirror of the above: the same shared path under the right + -- method resolves to the first matching leaf, never SecondFooR. + testRequestIO 200 ["foo", "neat"] (Just "FooNeatR") + + describe "total miss under fallthrough lands on the terminal 404" $ do + it "GET /foo/zzz exhausts both same-prefix parents -> 404" $ + -- /foo/zzz matches the /foo prefix of both FirstFooR and SecondFooR + -- but no leaf of either. Each parent reports a path miss ('Nothing'), + -- so dispatch falls through every sibling and lands on the terminal + -- 404 clause ("except in the final case" from the flag's haddock). + testRequestIO 404 ["foo", "zzz"] Nothing + it "GET /zzz matches no parent prefix at all -> 404" $ + -- A top-level total miss: no parent's prefix matches, so the only + -- clause that fires is the terminal 404. + testRequestIO 404 ["zzz"] Nothing diff --git a/test/YesodCoreTest/MultiPieceNestedRuntime.hs b/test/YesodCoreTest/MultiPieceNestedRuntime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/MultiPieceNestedRuntime.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | T3: a nested 'ResourceParent' whose OWN path pieces number more than one +-- and include a dynamic capture (@\/shop\/#Int\/admin@). Most nested-route tests +-- use single-piece parents; this stresses the multi-piece machinery — +-- 'handlePiecesNames' binding several pieces, 'mkPathPat' threading them, and +-- the @parentArgsExp@ tuple build that forwards the captured @#Int@ down to the +-- delegated child dispatch — and asserts both the round-trip and the misses. +module YesodCoreTest.MultiPieceNestedRuntime + ( specs + ) where + +import Test.Hspec +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text) +import Yesod.Core + +import YesodCoreTest.RuntimeHarness (assertGet) + +data MPApp = MPApp + +mkYesod "MPApp" [parseRoutes| +/shop/#Int/admin ShopAdminR: + / ShopAdminIndexR GET + /users/#Text UserR GET +|] + +instance Yesod MPApp where + messageLoggerSource = mempty + +getShopAdminIndexR :: Int -> HandlerFor MPApp String +getShopAdminIndexR shopId = pure ("admin:" <> show shopId) + +getUserR :: Int -> Text -> HandlerFor MPApp String +getUserR shopId name = pure ("user:" <> show shopId <> ":" <> show name) + +testRequestIO :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO () +testRequestIO = assertGet MPApp + +specs :: Spec +specs = describe "multi-piece nested parent (/shop/#Int/admin)" $ do + it "dispatches the parent index, forwarding the captured #Int" $ + testRequestIO 200 ["shop", "5", "admin"] (Just "admin:5") + it "dispatches a child, forwarding both the parent #Int and child #Text" $ + testRequestIO 200 ["shop", "5", "admin", "users", "bob"] (Just "user:5:\"bob\"") + it "404s on an unknown suffix under the multi-piece parent" $ + testRequestIO 404 ["shop", "5", "admin", "nope"] Nothing + it "404s when the parent's dynamic piece is malformed (#Int given a non-integer)" $ + testRequestIO 404 ["shop", "notanint", "admin"] Nothing diff --git a/test/YesodCoreTest/NestedDispatch/InnerR.hs b/test/YesodCoreTest/NestedDispatch/InnerR.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/NestedDispatch/InnerR.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Bug-2 regression fixture: @InnerR@ is split out into its own focused +-- module (so a @RouteAttrsNested InnerR@ instance is in scope), while its +-- parent @OuterR@ is /not/ split — the main @App@ module inlines @OuterR@. +-- +-- When the full @RouteAttrs App@ instance descends through the inlined +-- @OuterR@ and reaches the delegated @InnerR@, the generated @routeAttrs@ +-- clause must apply the accumulated ancestor pattern (@front@), producing +-- @routeAttrs (OuterR (InnerR _ x)) = routeAttrsNested x@. Dropping @front@ +-- (the bug) would emit @routeAttrs (InnerR x) = …@, which fails to compile +-- because @Route App@ has no top-level @InnerR@ constructor. +module YesodCoreTest.NestedDispatch.InnerR where + +import Data.Text (Text) +import YesodCoreTest.NestedDispatch.Resources +import Yesod.Core + +mkYesodOpts (setFocusOnNestedRoute "InnerR" defaultOpts) "App" nestedDispatchResources + +getInnerIndexR :: HandlerFor App Text +getInnerIndexR = pure "getInnerIndexR" diff --git a/test/YesodCoreTest/NestedDispatch/NestR.hs b/test/YesodCoreTest/NestedDispatch/NestR.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/NestedDispatch/NestR.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Split-out @NestR@ fragment of the "YesodCoreTest.NestedDispatch.Runtime" demo. The +-- @setFocusOnNestedRoute "NestR"@ splice generates the @NestR@ datatype and its +-- @YesodDispatchNested@ instance here; the @App@ module delegates to it. The +-- single @NestIndexR@ leaf handles both GET and POST, covering a zero-piece +-- nested index reached through delegation. +module YesodCoreTest.NestedDispatch.NestR where + +import Yesod.Core +import Data.Text (Text) +import YesodCoreTest.NestedDispatch.Resources + +mkYesodOpts (setFocusOnNestedRoute "NestR" defaultOpts) "App" nestedDispatchResources + +getNestIndexR :: HandlerFor App Text +getNestIndexR = pure "getNestIndexR" + +postNestIndexR :: HandlerFor App String +postNestIndexR = pure "hello" diff --git a/test/YesodCoreTest/NestedDispatch/Parent0R.hs b/test/YesodCoreTest/NestedDispatch/Parent0R.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/NestedDispatch/Parent0R.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + + +-- | Split-out @Parent0R@ fragment of the "YesodCoreTest.NestedDispatch.Runtime" demo. +-- Besides delegation, this module pins two non-obvious cases: a multipiece +-- (@*Texts@) leaf under a split-out parent (see 'getFilesR' below), and a +-- /grandchild/ parent @Child0R@ nested two levels deep. This focused splice +-- generates both @Parent0R@ and its grandchild @Child0R@ datatype\/instance; +-- the grandchild's leaf /handlers/ live in +-- "YesodCoreTest.NestedDispatch.Parent0R.Child0R". +module YesodCoreTest.NestedDispatch.Parent0R where + +import Data.Text (Text) +import qualified Data.Text as Text +import Yesod.Core.Handler +import YesodCoreTest.NestedDispatch.Resources +import Yesod.Core +import YesodCoreTest.NestedDispatch.Parent0R.Child0R + +mkYesodOpts (setFocusOnNestedRoute "Parent0R" defaultOpts) "App" nestedDispatchResources + +getParent0IndexR :: Int -> HandlerFor App Text +getParent0IndexR = pure . Text.pack . show + +-- | A multi-piece (@*Texts@) leaf nested under a split-out parent. This is the +-- regression fixture for the nested-dispatch generator dropping the trailing +-- multipiece (it hardcoded 'EndExact' and built the constructor one arg short), +-- which fails to compile this focused dispatch unless the multi is bound, +-- appended to the route constructor, and forwarded to the handler. +getFilesR :: Int -> [Text] -> HandlerFor App Text +getFilesR i ts = return (Text.pack (show i) <> ":" <> Text.pack (show ts)) diff --git a/test/YesodCoreTest/NestedDispatch/Parent0R/Child0R.hs b/test/YesodCoreTest/NestedDispatch/Parent0R/Child0R.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/NestedDispatch/Parent0R/Child0R.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Leaf handlers for the grandchild parent @Child0R@ of the +-- "YesodCoreTest.NestedDispatch.Runtime" demo. Non-obvious: this module defines /only/ +-- the handlers — the @Child0R@ datatype and its dispatch instance are emitted +-- by the focused @Parent0R@ splice (one level up), since focusing on a parent +-- also generates its descendants' nested instances. +module YesodCoreTest.NestedDispatch.Parent0R.Child0R where + +import Data.Text (Text) +import qualified Data.Text as Text +import Yesod.Core.Handler +import YesodCoreTest.NestedDispatch.Resources +import Yesod.Core + +postParentChildIndexR :: Int -> Text -> HandlerFor App Text +postParentChildIndexR i t = pure $ Text.pack $ show (i, t) + +getParentChildIndexR :: Int -> Text -> HandlerFor App Text +getParentChildIndexR = postParentChildIndexR + +postParentChildR :: Int -> Text -> String -> HandlerFor App Text +postParentChildR i t c = pure $ Text.pack $ show (i, t, c) + +getParentChildR :: Int -> Text -> String -> HandlerFor App Text +getParentChildR = postParentChildR diff --git a/test/YesodCoreTest/NestedDispatch/ParentR.hs b/test/YesodCoreTest/NestedDispatch/ParentR.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/NestedDispatch/ParentR.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Split-out @ParentR@ fragment of the "YesodCoreTest.NestedDispatch.Runtime" demo. +-- The @setFocusOnNestedRoute "ParentR"@ splice emits the @ParentR@ datatype and +-- its @YesodDispatchNested@ instance here, alongside the child handlers; the +-- main @App@ module reaches these only by delegation. Exercises a dynamic +-- parent piece (@\/parent\/#Int@) feeding its captured arg to the children. +module YesodCoreTest.NestedDispatch.ParentR where + +import Data.Text (Text) +import qualified Data.Text as Text +import Yesod.Core.Handler +import YesodCoreTest.NestedDispatch.Resources +import Yesod.Core + +mkYesodOpts (setFocusOnNestedRoute "ParentR" defaultOpts) "App" nestedDispatchResources + +handleChild1R :: Int -> Text -> HandlerFor App Text +handleChild1R i t = return (Text.pack (show i) <> t) + +getChild2R :: Int -> Int -> HandlerFor App Text +getChild2R i0 i1 = return ("GET" <> Text.pack (show (i0, i1))) + +postChild2R :: Int -> Int -> HandlerFor App Text +postChild2R i0 i1 = return ("POST" <> Text.pack (show (i0, i1))) diff --git a/test/YesodCoreTest/NestedDispatch/Resources.hs b/test/YesodCoreTest/NestedDispatch/Resources.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/NestedDispatch/Resources.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Shared route table + foundation type for the "YesodCoreTest.NestedDispatch.Runtime" +-- demo and its split-out parent modules. Lives in its own module so every +-- @setFocusOnNestedRoute@ splice (NestR, ParentR, Parent0R, ...) can refer to +-- the same @nestedDispatchResources@ tree without tripping the TH stage +-- restriction. The tree deliberately mixes flat routes, single- and +-- multi-piece dynamic parents, a multipiece (@*Texts@) leaf, and same-prefix +-- siblings to exercise the breadth of the nested-dispatch generator. +module YesodCoreTest.NestedDispatch.Resources where + +import Yesod.Core +import Yesod.Routes.TH.Types + +data App = App + +nestedDispatchResources :: [ResourceTree String] +nestedDispatchResources = [parseRoutes| +/ HomeR GET !home +/json JsonR GET + +/redirectparent RedirectParentR GET +/redirecttext RedirectTextR GET +/redirectstring RedirectStringR GET +/redirectparams RedirectParamsR GET +/nest NestR: + / NestIndexR GET POST + +/parent/#Int ParentR: + /#Text/child1 Child1R !child + /#Int/child2 Child2R !child GET POST + +/parent0/#Int Parent0R: + / Parent0IndexR GET + + /files/*Texts FilesR GET + + /child0/#Text Child0R: + / ParentChildIndexR GET POST + /#String ParentChildR GET POST + +/nest OtherNestR: + /foo NestFooR GET + +/outer OuterR: + /inner InnerR: + / InnerIndexR GET !innerleaf + +/blah BlahR: + / BlahIndexR GET + +/robots.txt RobotsR: + / RobotsIndexR +|] diff --git a/test/YesodCoreTest/NestedDispatch/Runtime.hs b/test/YesodCoreTest/NestedDispatch/Runtime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/NestedDispatch/Runtime.hs @@ -0,0 +1,599 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | The headline nested-route-dispatch demo. @mkYesod "App"@ here generates a +-- @YesodDispatch App@ whose flat dispatch /delegates/ to a per-parent +-- @YesodDispatchNested@ instance for every @ResourceParent@ in the tree (NestR, +-- ParentR, Parent0R, OuterR, ...). Each such instance is generated in-splice by +-- this module, /unless/ a sibling module already provides it: NestR\/ParentR\/ +-- Parent0R\/Child0R are split out (each via @setFocusOnNestedRoute@) so their +-- handlers and instances live elsewhere and are only reached through delegation. +-- The .Resources module holds the shared route table; the WAI specs here drive +-- real requests through the delegated dispatch. +module YesodCoreTest.NestedDispatch.Runtime + ( specs + , Widget + , resourcesApp + ) where + +import Yesod.Core +import Yesod.Core.Class.Dispatch.ToParentRoute (toParentRoute) +import Test.Hspec +import Network.Wai +import Network.Wai.Test +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Char8 as S8 +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Maybe (fromJust) +import Data.Proxy (Proxy (..)) +import Data.Monoid (Endo (..)) +import qualified Control.Monad.Trans.Writer as Writer +import qualified Data.Set as Set +import YesodCoreTest.NestedDispatch.Resources +import YesodCoreTest.NestedDispatch.NestR (NestR(..)) +import YesodCoreTest.NestedDispatch.InnerR (InnerR(..)) +import YesodCoreTest.NestedDispatch.ParentR (ParentR(..)) +import YesodCoreTest.NestedDispatch.Parent0R (Parent0R(..), Child0R(..)) +import YesodCoreTest.NestedDispatch.Parent0R.Child0R +import YesodCoreTest.RuntimeHarness (assertRequestRaw) +import qualified Network.HTTP.Types as H + +mkYesod "App" nestedDispatchResources + +getBlahIndexR :: HandlerFor App Text +getBlahIndexR = pure "getBlahIndexR" + +instance Yesod App where + messageLoggerSource = mempty + +specialHtml :: IsString a => a +specialHtml = "text/html; charset=special" + +tshow :: Show a => a -> Text +tshow = Text.pack . show + +handleRobotsIndexR :: HandlerFor site Text +handleRobotsIndexR = pure "robots.txt" + +getHomeR :: Handler TypedContent +getHomeR = selectRep $ do + rep typeHtml "HTML" + rep specialHtml "HTMLSPECIAL" + rep typeXml "XML" + rep typeJson "JSON" + +getNestFooR :: Handler () +getNestFooR = pure () + +-- | Redirects through the 'RedirectUrl' instance for 'WithParentArgs', which +-- routes via @toTextUrl (toParentRoute args url)@. Pins that the Location +-- header for a nested fragment is rendered identically to the full route. +getRedirectParentR :: Handler () +getRedirectParentR = redirect (WithParentArgs (1 :: Int) (Child1R "hello")) + +-- | Exercises @RedirectUrl master Text@. +getRedirectTextR :: Handler () +getRedirectTextR = redirect ("/some/where" :: Text) + +-- | Exercises @RedirectUrl master String@. +getRedirectStringR :: Handler () +getRedirectStringR = redirect ("/some/string" :: String) + +-- | Exercises @RedirectUrl master (Route master, [(Text, Text)])@. +getRedirectParamsR :: Handler () +getRedirectParamsR = redirect (JsonR, [("q", "1")] :: [(Text, Text)]) + +rep :: Monad m => ContentType -> Text -> Writer.Writer (Data.Monoid.Endo [ProvidedRep m]) () +rep ct t = provideRepType ct $ return (t :: Text) + +getJsonR :: Handler TypedContent +getJsonR = selectRep $ do + rep typeHtml "HTML" + provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)] + +testRequest :: Int -- ^ http status code + -> Request + -> ByteString -- ^ expected body + -> Spec +testRequest status req expected = it (S8.unpack $ fromJust $ lookup "Accept" $ requestHeaders req) $ do + testRequestIO status req (Just expected) + +testRequestIO :: HasCallStack => Int -- ^ http status code + -> Request + -> Maybe ByteString -- ^ expected body + -> IO () +testRequestIO status req mexpected = + assertRequestRaw (toWaiApp App) req status mexpected + +test :: String -- ^ accept header + -> ByteString -- ^ expected body + -> Spec +test accept expected = + testRequest 200 (acceptRequest accept) expected + +acceptRequest :: String -> Request +acceptRequest accept = defaultRequest + { requestHeaders = [("Accept", S8.pack accept)] + } + +-- | Build a WAI app rooted at a nested route fragment (via the public +-- 'toWaiAppPlainNested' entry point), issue one GET at @path@, and return the +-- status code. +nestedStatusFor + :: (ParentSite route ~ App, YesodDispatchNested route, ToParentRoute route) + => Proxy route -> ParentArgs route -> [Text] -> IO Int +nestedStatusFor proxy parentArgs path = do + app <- toWaiAppPlainNested proxy parentArgs App + sres <- flip runSession app $ request defaultRequest { pathInfo = path } + pure $ H.statusCode (simpleStatus sres) + + +specs :: Spec +specs = do + describe "Dispatch" $ do + describe "properly does nested dispatch" $ do + describe "NestR" $ do + it "GET" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = ["nest"] + , requestMethod = "GET" + } + (Just "getNestIndexR") + it "POST" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = ["nest"] + , requestMethod = "POST" + } + (Just "hello") + it "invalid route" $ do + testRequestIO + 404 + defaultRequest + { pathInfo = ["nest", "oops"] + , requestMethod = "GET" + } + Nothing + it "invalid method" $ do + testRequestIO + 405 + defaultRequest + { pathInfo = ["nest"] + , requestMethod = "PUT" + } + Nothing + + describe "ParentR" $ do + describe "Child1R" $ do + it "works" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = + ["parent", tshow @Int 1, "hello", "child1"] + } + (Just "1hello") + + describe "Child2R" $ do + it "GET" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = + ["parent", tshow @Int 1, tshow @Int 3, "child2"] + , requestMethod = "GET" + } + (Just "GET(1,3)") + it "POST" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = + ["parent", tshow @Int 1, tshow @Int 3, "child2"] + , requestMethod = "POST" + } + (Just "POST(1,3)") + it "PUT" $ do + testRequestIO + 405 + defaultRequest + { pathInfo = + ["parent", tshow @Int 1, tshow @Int 3, "child2"] + , requestMethod = "PUT" + } + Nothing + + describe "Parent0R" $ do + describe "FilesR (multi-piece *Texts leaf under a split parent)" $ do + it "dispatches a non-empty tail, forwarding parent #Int and the multipiece" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = ["parent0", tshow @Int 7, "files", "a", "b"] + , requestMethod = "GET" + } + (Just "7:[\"a\",\"b\"]") + it "dispatches an empty tail as the empty multipiece" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = ["parent0", tshow @Int 7, "files"] + , requestMethod = "GET" + } + (Just "7:[]") + it "405s on a non-GET method" $ do + testRequestIO + 405 + defaultRequest + { pathInfo = ["parent0", tshow @Int 7, "files", "a", "b"] + , requestMethod = "POST" + } + Nothing + + describe "Parent0IndexR" $ do + it "GET works" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = + ["parent0", tshow @Int 1] + , requestMethod = "GET" + } + (Just "1") + it "POST errors" $ do + testRequestIO + 405 + defaultRequest + { pathInfo = + ["parent0", tshow @Int 1] + , requestMethod = "POST" + } + Nothing + + describe "Child0R" $ do + describe "ParentChildIndexR" $ do + it "GET works" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = + ["parent0", tshow @Int 1, "child0", "asdf"] + , requestMethod = "GET" + } + (Just "(1,\"asdf\")") + it "POST works" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = + ["parent0", tshow @Int 2, "child0", "asdf"] + , requestMethod = "POST" + } + (Just "(2,\"asdf\")") + it "PUT errors" $ do + testRequestIO + 405 + defaultRequest + { pathInfo = + ["parent0", tshow @Int 2, "child0", "asdf"] + , requestMethod = "PUT" + } + Nothing + + describe "ParentChildR" $ do + it "GET works" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = + ["parent0", tshow @Int 1, "child0", "asdf", "foobar"] + , requestMethod = "GET" + } + (Just "(1,\"asdf\",\"foobar\")") + it "POST works" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = + ["parent0", tshow @Int 1, "child0", "asdf", "foobar"] + , requestMethod = "POST" + } + (Just "(1,\"asdf\",\"foobar\")") + it "PUT fails" $ do + testRequestIO + 405 + defaultRequest + { pathInfo = + ["parent0", tshow @Int 1, "child0", "asdf", "foobar"] + , requestMethod = "PUT" + } + Nothing + + describe "trailing-slash redirect (cleanPath) for a nested route" $ do + it "301s a trailing slash on a GET to a split nested route" $ do + testRequestIO + 301 + defaultRequest + { pathInfo = ["parent", tshow @Int 1, tshow @Int 3, "child2", ""] + , requestMethod = "GET" + } + Nothing + + describe "nested-dispatch entry points (miss / deep 404)" $ do + -- These exercise toWaiAppPlainNested/toWaiAppYreNested directly, not just + -- the happy path. In particular they cover the `Nothing -> notFound` + -- branch in toWaiAppYreNested (a fragment instance returning Nothing on a + -- non-match) and confirm a `drop parentDepth` against a too-short pathInfo + -- yields a clean 404 rather than a mis-dispatch. + describe "rooted at NestR (no dynamic prefix, depth 1)" $ do + it "dispatches the matching index path" $ + nestedStatusFor (Proxy :: Proxy NestR) () ["nest"] + `shouldReturn` 200 + it "404s a non-matching tail through the Nothing -> notFound branch" $ + nestedStatusFor (Proxy :: Proxy NestR) () ["nest", "oops"] + `shouldReturn` 404 + + describe "rooted at a deep dynamic parent (ParentR/#Int, depth 2)" $ do + it "dispatches a full matching path" $ + nestedStatusFor (Proxy :: Proxy ParentR) (1 :: Int) + ["parent", "1", "hello", "child1"] + `shouldReturn` 200 + it "cleanly 404s a pathInfo shorter than the parent depth" $ + nestedStatusFor (Proxy :: Proxy ParentR) (1 :: Int) ["parent"] + `shouldReturn` 404 + it "cleanly 404s an empty pathInfo" $ + nestedStatusFor (Proxy :: Proxy ParentR) (1 :: Int) [] + `shouldReturn` 404 + it "404s a non-matching deep tail" $ + nestedStatusFor (Proxy :: Proxy ParentR) (1 :: Int) + ["parent", "1", "nope"] + `shouldReturn` 404 + + describe "UrlToDispatch NestIndexR" $ do + it "works" $ do + yre <- mkYesodRunnerEnv App + let app = urlToDispatch NestIndexR yre + req = defaultRequest + { pathInfo = ["nest"] + , requestMethod = "GET" + } + sres <- flip runSession app $ do + request req + H.statusCode (simpleStatus sres) `shouldBe` 200 + simpleBody sres `shouldBe` "getNestIndexR" + + describe "UrlToDispatch (WithParentArgs route)" $ do + -- Exercises the only UrlToDispatch instance with real args-threading + -- logic (Yesod.Core.Class.Dispatch): a fragment plus its dynamic parent + -- args is turned into a WAI app that dispatches into the right handler. + it "dispatches a dynamic-parent fragment to the right handler (200)" $ do + yre <- mkYesodRunnerEnv App + let app = + urlToDispatch + (WithParentArgs (1 :: Int) (Child1R "hello")) + yre + req = defaultRequest + { pathInfo = ["parent", "1", "hello", "child1"] + , requestMethod = "GET" + } + sres <- flip runSession app $ request req + H.statusCode (simpleStatus sres) `shouldBe` 200 + simpleBody sres `shouldBe` "1hello" + it "404s a path whose parent arg disagrees with the request path" $ do + -- The fragment app is rooted at parent arg 1, but it still parses the + -- path off the request; a path that doesn't match the fragment 404s. + yre <- mkYesodRunnerEnv App + let app = + urlToDispatch + (WithParentArgs (1 :: Int) (Child1R "hello")) + yre + req = defaultRequest + { pathInfo = ["parent", "1", "hello", "nope"] + , requestMethod = "GET" + } + sres <- flip runSession app $ request req + H.statusCode (simpleStatus sres) `shouldBe` 404 + + describe "UrlToDispatch (Route site) / Text / String / (Route, params)" $ do + -- The plain hand-written instances all just forward to yesodDispatch; + -- pin that they actually dispatch (rather than e.g. always 404). The + -- url value is ignored by these instances, so we always request /nest. + let dispatchVia :: UrlToDispatch url App => url -> IO SResponse + dispatchVia url = do + yre <- mkYesodRunnerEnv App + let app = urlToDispatch url yre + req = defaultRequest { pathInfo = ["nest"], requestMethod = "GET" } + flip runSession app $ request req + expectNest sres = do + H.statusCode (simpleStatus sres) `shouldBe` 200 + simpleBody sres `shouldBe` "getNestIndexR" + it "UrlToDispatch (Route site)" $ + dispatchVia (HomeR :: Route App) >>= expectNest + it "UrlToDispatch (Route site, params)" $ + dispatchVia (HomeR :: Route App, [] :: [(Text, Text)]) >>= expectNest + it "UrlToDispatch Text" $ + dispatchVia ("ignored" :: Text) >>= expectNest + it "UrlToDispatch String" $ + dispatchVia ("ignored" :: String) >>= expectNest + + describe "RedirectUrl (WithParentArgs url) Location header" $ do + -- Pins toTextUrl . toParentRoute: a handler redirecting via a fragment + -- + parent args must render the same Location as the full route would. + it "renders the full nested route as the Location" $ do + app <- toWaiApp App + sres <- flip runSession app $ + request defaultRequest + { pathInfo = ["redirectparent"] + , requestMethod = "GET" + , httpVersion = H.http11 + } + H.statusCode (simpleStatus sres) `shouldBe` 303 + lookup "Location" (simpleHeaders sres) + `shouldBe` Just "/parent/1/hello/child1" + + describe "RedirectUrl Text / String / (Route, params) Location header" $ do + -- The unexercised simple RedirectUrl instances, end to end through a + -- handler redirect. + it "redirects via plain Text" $ do + app <- toWaiApp App + sres <- flip runSession app $ + request defaultRequest + { pathInfo = ["redirecttext"] + , requestMethod = "GET" + , httpVersion = H.http11 + } + H.statusCode (simpleStatus sres) `shouldBe` 303 + lookup "Location" (simpleHeaders sres) + `shouldBe` Just "/some/where" + it "redirects via plain String" $ do + app <- toWaiApp App + sres <- flip runSession app $ + request defaultRequest + { pathInfo = ["redirectstring"] + , requestMethod = "GET" + , httpVersion = H.http11 + } + H.statusCode (simpleStatus sres) `shouldBe` 303 + lookup "Location" (simpleHeaders sres) + `shouldBe` Just "/some/string" + it "redirects via (Route, params)" $ do + app <- toWaiApp App + sres <- flip runSession app $ + request defaultRequest + { pathInfo = ["redirectparams"] + , requestMethod = "GET" + , httpVersion = H.http11 + } + H.statusCode (simpleStatus sres) `shouldBe` 303 + lookup "Location" (simpleHeaders sres) + `shouldBe` Just "/json?q=1" + + describe "RenderRouteNested (WithParentArgs a)" $ do + it "agrees with renderRoute of the equivalent full Route" $ do + renderRouteNested () (WithParentArgs (1 :: Int) (Child1R "hello")) + `shouldBe` + renderRoute (toParentRoute (1 :: Int) (Child1R "hello")) + -- and concretely, the full path: + renderRouteNested () (WithParentArgs (1 :: Int) (Child1R "hello")) + `shouldBe` + renderRoute (ParentR 1 (Child1R "hello")) + + + describe "selectRep" $ do + test "application/json" "JSON" + test (S8.unpack typeJson) "JSON" + test "text/xml" "XML" + test (S8.unpack typeXml) "XML" + test "text/xml,application/json" "XML" + test "text/xml;q=0.9,application/json;q=1.0" "JSON" + test (S8.unpack typeHtml) "HTML" + test "text/html" "HTML" + test specialHtml "HTMLSPECIAL" + testRequest 200 (acceptRequest "application/json") { pathInfo = ["json"] } "{\"message\":\"Invalid Login\"}" + test "text/*" "HTML" + test "*/*" "HTML" + describe "routeAttrs" $ do + it "HomeR" $ routeAttrs HomeR `shouldBe` Set.singleton "home" + it "JsonR" $ routeAttrs JsonR `shouldBe` Set.empty + it "ChildR" $ routeAttrs (ParentR 5 $ Child1R "ignored") `shouldBe` Set.singleton "child" + -- Bug-2 regression: InnerR is split (RouteAttrsNested InnerR), OuterR is + -- inlined. The generated clause must carry the OuterR ancestor pattern. + it "InnerIndexR (split parent under an inlined parent)" $ + routeAttrs (OuterR (InnerR InnerIndexR)) `shouldBe` Set.singleton "innerleaf" + + describe "OuterR (inlined parent delegating to a split InnerR)" $ do + it "dispatches /outer/inner" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = ["outer", "inner"] + , requestMethod = "GET" + } + (Just "getInnerIndexR") + + describe "fallthrough" $ do + it "is 404 because fallthrough is disabled" $ do + testRequestIO + 404 + defaultRequest + { pathInfo = ["nest", "foo"] + , requestMethod = "GET" + } + Nothing + + describe "BlahR" $ do + -- This test is to verify that you can promote a singleton route- + -- ie, that + -- + -- > /blah BlahR GET + -- + -- and + -- + -- > /blah BlahR: + -- > / BlahIndexR GET + -- + -- are equivalent + it "can access with just the prefix" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = ["blah"] + , requestMethod = "GET" + } + (Just "getBlahIndexR") + + it "can access a filename route" $ do + testRequestIO + 200 + defaultRequest + { pathInfo = ["robots.txt"] + , requestMethod = "GET" + } + (Just "robots.txt") + + describe "ToParentRoute" $ do + describe "Route App" $ do + it "works with no args" $ do + toParentRoute () HomeR `shouldBe` HomeR + it "works with args" $ do + toParentRoute () (ParentR 1 (Child1R "hello")) + `shouldBe` + (ParentR 1 (Child1R "hello")) + describe "ParentR" $ do + it "works" $ do + toParentRoute 3 (Child1R "Hello") + `shouldBe` + ParentR 3 (Child1R "Hello") + + describe "Parent0R" $ do + it "works" $ do + toParentRoute 3 Parent0IndexR + `shouldBe` + Parent0R 3 Parent0IndexR + + describe "Child0R" $ do + it "works" $ do + toParentRoute (3, "hello") ParentChildIndexR + `shouldBe` + Parent0R 3 (Child0R "hello" ParentChildIndexR) + + it "works with arg" $ do + toParentRoute (3, "hello") (ParentChildR "asdf") + `shouldBe` + Parent0R 3 (Child0R "hello" (ParentChildR "asdf")) diff --git a/test/YesodCoreTest/ParamDefaultSplit/Data.hs b/test/YesodCoreTest/ParamDefaultSplit/Data.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamDefaultSplit/Data.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Route data for a delegation-probe regression: a *parameterized* top-level site with a +-- nested route, generated with /default/ opts (i.e. NOT +-- 'setParameterizedSubroute'), so the nested datatype 'SubParentDR' is +-- generated at kind 'Type'. The matching dispatch splice lives in the +-- separately compiled "YesodCoreTest.ParamDefaultSplit.Runtime", so the child +-- datatype is in scope there — the precise shape that made the @go@ delegation +-- probe build the ill-kinded @SubParentDR a@ and abort the splice. +module YesodCoreTest.ParamDefaultSplit.Data where + +import Yesod.Core + +data PolyD a = PolyD a + +mkYesodData "PolyD a" [parseRoutes| +/ HomeDR GET +/item/#Int ItemDR GET +/sub SubParentDR: + / SubHomeDR GET + /detail/#Int SubDetailDR GET +|] diff --git a/test/YesodCoreTest/ParamDefaultSplit/Runtime.hs b/test/YesodCoreTest/ParamDefaultSplit/Runtime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamDefaultSplit/Runtime.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Delegation-probe regression: a *parameterized* site (@PolyD a@) with a nested route, +-- using /default/ opts (opted out of nested-route discovery), with the route +-- data and the dispatch splice /split across modules/. +-- +-- The dispatch splice's @go@ delegation probe must saturate the in-scope child +-- datatype 'SubParentDR' by its own reified arity (0) — NOT by the site's type +-- args — or it builds the ill-kinded @SubParentDR a@ and @isInstance@ throws a +-- kind error that aborts the splice. So this module compiling at all is the +-- regression assertion; the WAI tests confirm the inlined dispatch still works. +module YesodCoreTest.ParamDefaultSplit.Runtime + ( specs + ) where + +import Data.Text (Text) +import Test.Hspec +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Types as H +import Yesod.Core + +import YesodCoreTest.ParamDefaultSplit.Data +import YesodCoreTest.RuntimeHarness (assertRequestFor) + +mkYesodDispatch "PolyD a" resourcesPolyD + +instance Yesod (PolyD a) where + messageLoggerSource = mempty + +getHomeDR :: HandlerFor (PolyD a) Text +getHomeDR = pure "home" + +getItemDR :: Int -> HandlerFor (PolyD a) Text +getItemDR _ = pure "item" + +getSubHomeDR :: HandlerFor (PolyD a) Text +getSubHomeDR = pure "subHome" + +getSubDetailDR :: Int -> HandlerFor (PolyD a) Text +getSubDetailDR _ = pure "subDetail" + +sampleRoutes :: [Route (PolyD ())] +sampleRoutes = + [ HomeDR + , ItemDR 7 + , SubParentDR SubHomeDR + , SubParentDR (SubDetailDR 9) + ] + +testRequestIO + :: HasCallStack + => Int + -> [Text] + -> H.Method + -> Maybe L.ByteString + -> IO () +testRequestIO status path method mexpected = + assertRequestFor (PolyD ()) method status path mexpected + +specs :: Spec +specs = describe "parameterized site, default opts, nested route split across modules" $ do + describe "parseRoute . renderRoute round-trips" $ + mapM_ + (\r -> it (show r) $ parseRoute (renderRoute r) `shouldBe` Just r) + sampleRoutes + + describe "WAI dispatch (inlined, not delegated)" $ do + it "static leaf (HomeDR)" $ + testRequestIO 200 [] "GET" (Just "home") + it "dynamic leaf (ItemDR)" $ + testRequestIO 200 ["item", "7"] "GET" (Just "item") + it "nested parent home (SubParentDR SubHomeDR)" $ + testRequestIO 200 ["sub"] "GET" (Just "subHome") + it "nested parent dynamic leaf (SubParentDR (SubDetailDR _))" $ + testRequestIO 200 ["sub", "detail", "9"] "GET" (Just "subDetail") + it "404 on unknown nested suffix" $ + testRequestIO 404 ["sub", "detail", "9", "oops"] "GET" Nothing + it "405 on wrong method" $ + testRequestIO 405 ["sub"] "POST" Nothing diff --git a/test/YesodCoreTest/ParamFallthroughRuntime.hs b/test/YesodCoreTest/ParamFallthroughRuntime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamFallthroughRuntime.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Runtime coverage for nested-route /fallthrough/ on a *parameterized* site. +-- The monomorphic fallthrough test ("YesodCoreTest.FallthroughDispatch.Runtime") +-- exercises the @setNestedRouteFallthrough@ fallback only for an +-- unparameterized site; this is the parameterized counterpart, opted into +-- nested discovery so the parameterized subroute datatypes carry the type +-- variable while several same-prefix parents fall through to one another. +module YesodCoreTest.ParamFallthroughRuntime + ( specs + ) where + +import Test.Hspec +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text) +import Yesod.Core + +import YesodCoreTest.RuntimeHarness (assertGet) + +data PApp a = PApp a + +mkYesodOpts + (setNestedRouteFallthrough True (setParameterizedSubroute True defaultOpts)) + "PApp a" + [parseRoutesNoCheck| +/foo FirstFooR: + / FooIndexR + /neat FooNeatR + +/foo SecondFooR: + / NeverFiresR + /other OtherR + +/foo/#Int ParamFooR: + / FooWithIntR + +/foo/#String TextFooR: + / FooWithTextR +|] + +instance Yesod (PApp a) where + messageLoggerSource = mempty + +handleFooIndexR :: HandlerFor app String +handleFooIndexR = pure "FooIndexR" + +handleOtherR :: HandlerFor app String +handleOtherR = pure "OtherR" + +handleFooNeatR :: HandlerFor app String +handleFooNeatR = pure "FooNeatR" + +handleNeverFiresR :: HandlerFor app String +handleNeverFiresR = pure "NeverFiresR" + +handleFooWithIntR :: Int -> HandlerFor app String +handleFooWithIntR i = pure $ "FooWithIntR " <> show i + +handleFooWithTextR :: String -> HandlerFor app String +handleFooWithTextR str = pure $ "FooWithTextR " <> str + +testRequestIO :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO () +testRequestIO = assertGet (PApp ()) + +specs :: Spec +specs = describe "parameterized site, nested-route fallthrough" $ do + it "matches the first parent's index (FooIndexR at /foo)" $ + testRequestIO 200 ["foo"] (Just "FooIndexR") + it "matches a child of the first parent (FooNeatR at /foo/neat)" $ + testRequestIO 200 ["foo", "neat"] (Just "FooNeatR") + it "falls through to a later same-prefix parent (OtherR at /foo/other)" $ + testRequestIO 200 ["foo", "other"] (Just "OtherR") + it "falls through to the dynamic-prefix parent (FooWithIntR at /foo/3)" $ + testRequestIO 200 ["foo", "3"] (Just "FooWithIntR 3") + it "falls through to the textual-prefix parent (FooWithTextR at /foo/asdf)" $ + testRequestIO 200 ["foo", "asdf"] (Just "FooWithTextR asdf") diff --git a/test/YesodCoreTest/ParamFocusSplit/Resources.hs b/test/YesodCoreTest/ParamFocusSplit/Resources.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamFocusSplit/Resources.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Shared route tree + foundation datatype for the parameterized +-- focus-split fixture ("YesodCoreTest.ParamFocusSplit.Runtime" and its +-- @.SubR@ fragment module). The foundation @PApp a@ carries one type +-- argument, so this drives the @TyArgs@-applying focused codegen paths. +module YesodCoreTest.ParamFocusSplit.Resources where + +import Yesod.Core +import Yesod.Routes.TH.Types (ResourceTree) + +-- | A phantom-parameterized top-level site (kind @Type -> Type@). +data PApp a = PApp + +paramFocusResources :: [ResourceTree String] +paramFocusResources = [parseRoutes| +/ HomeR GET +/item/#Int ItemR GET +/sub SubR: + / SubHomeR GET + /detail/#Int SubDetailR GET +|] diff --git a/test/YesodCoreTest/ParamFocusSplit/Runtime.hs b/test/YesodCoreTest/ParamFocusSplit/Runtime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamFocusSplit/Runtime.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Runtime + round-trip coverage for a *parameterized* top-level site whose +-- nested route block is split into its own module with +-- 'setFocusOnNestedRoute'. Before this fixture the +-- @parameterized + setFocusOnNestedRoute@ corner was never compiled by any +-- test, and the focused 'RouteAttrsNested' instance head was built from a bare +-- constructor (no type argument applied) — a guaranteed kind error for a +-- parameterized site. The parent dispatch is generated here with +-- 'setParameterizedSubroute', so it must *delegate* to the @SubR a@ fragment +-- instances compiled in "YesodCoreTest.ParamFocusSplit.SubR"; the build itself +-- is the split-delegation assertion and the WAI rows confirm dispatch. +module YesodCoreTest.ParamFocusSplit.Runtime + ( specs + ) where + +import Data.Text (Text) +import Test.Hspec +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Types as H +import Yesod.Core + +import YesodCoreTest.ParamFocusSplit.Resources +-- Brings the split 'SubR' datatype + its nested dispatch / parse / render / +-- attrs instances into scope. Importing the datatype (not @SubR ()@) is what +-- lets the parent splice's delegation probe resolve 'SubR' and delegate to the +-- imported instance instead of regenerating (and demanding) its handlers. +import YesodCoreTest.ParamFocusSplit.SubR (SubR (..)) +import YesodCoreTest.RuntimeHarness (assertRequestFor) + +-- The parent splice: generates the route data types and the parent dispatch. +-- 'setParameterizedSubroute' forces the NestedDiscovery path so the parent +-- delegates to the split 'SubR' fragment rather than inlining it. +mkYesodOpts (setParameterizedSubroute True defaultOpts) "PApp a" paramFocusResources + +instance Yesod (PApp a) where + messageLoggerSource = mempty + +getHomeR :: HandlerFor (PApp a) Text +getHomeR = pure "home" + +getItemR :: Int -> HandlerFor (PApp a) Text +getItemR _ = pure "item" + +sampleRoutes :: [Route (PApp ())] +sampleRoutes = + [ HomeR + , ItemR 7 + , SubR SubHomeR + , SubR (SubDetailR 9) + ] + +testRequestIO + :: HasCallStack + => Int + -> [Text] + -> H.Method + -> Maybe L.ByteString + -> IO () +testRequestIO status path method mexpected = + assertRequestFor (PApp :: PApp ()) method status path mexpected + +specs :: Spec +specs = describe "parameterized top-level site, nested routes split with setFocusOnNestedRoute" $ do + describe "parseRoute . renderRoute round-trips" $ + mapM_ + (\r -> it (show r) $ parseRoute (renderRoute r) `shouldBe` Just r) + sampleRoutes + + describe "WAI dispatch (parent delegates to the split SubR fragment)" $ do + it "static leaf (HomeR)" $ + testRequestIO 200 [] "GET" (Just "home") + it "dynamic leaf (ItemR)" $ + testRequestIO 200 ["item", "7"] "GET" (Just "item") + it "nested parent home (delegated SubR SubHomeR)" $ + testRequestIO 200 ["sub"] "GET" (Just "subHome") + it "nested parent dynamic leaf (delegated SubR (SubDetailR _))" $ + testRequestIO 200 ["sub", "detail", "9"] "GET" (Just "subDetail") + it "404 on unknown nested suffix" $ + testRequestIO 404 ["sub", "detail", "9", "oops"] "GET" Nothing + it "405 on wrong method" $ + testRequestIO 405 ["sub"] "POST" Nothing diff --git a/test/YesodCoreTest/ParamFocusSplit/SubR.hs b/test/YesodCoreTest/ParamFocusSplit/SubR.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamFocusSplit/SubR.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | The split-out @SubR@ fragment of the parameterized @PApp a@ site. The +-- focused splice ('setFocusOnNestedRoute') here emits only the @SubR a@ +-- fragment's dispatch / parse / render / attrs nested instances; the parent +-- "YesodCoreTest.ParamFocusSplit.Runtime" generates the rest and delegates to these. +-- This module is the compile-time pin for the focused parameterized codegen +-- (the @RouteAttrsNested (SubR a)@ instance head in particular, which used to +-- be built from a bare constructor without the site's type argument). +module YesodCoreTest.ParamFocusSplit.SubR where + +import Data.Text (Text) +import Yesod.Core +import YesodCoreTest.ParamFocusSplit.Resources + +mkYesodOpts + (setFocusOnNestedRoute "SubR" (setParameterizedSubroute True defaultOpts)) + "PApp a" + paramFocusResources + +getSubHomeR :: HandlerFor (PApp a) Text +getSubHomeR = pure "subHome" + +getSubDetailR :: Int -> HandlerFor (PApp a) Text +getSubDetailR _ = pure "subDetail" diff --git a/test/YesodCoreTest/ParamNestedNoFallthroughRuntime.hs b/test/YesodCoreTest/ParamNestedNoFallthroughRuntime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamNestedNoFallthroughRuntime.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Exercises the *delegated* (nested-instance) no-fallthrough dispatch path +-- for a 'ResourceParent' child. +-- +-- "YesodCoreTest.ParamNoFallthroughRuntime" is two levels deep (parent -> +-- leaf), so the parent's generated @YesodDispatchNested@ instance only ever +-- dispatches to leaf children. This module goes three levels deep +-- (grandparent -> parent -> leaf) under nested discovery (the site carries a +-- type parameter), so the grandparent's nested instance dispatches to the +-- *inner parent* via 'genNestedDispatchClauses' @ResourceParent@ arm — the arm +-- that, with fallthrough disabled, must convert an inner @Nothing@ into a 404 +-- commit rather than returning the raw @Maybe@ (which under an outer +-- fallthrough caller would leak through to sibling routes). +module YesodCoreTest.ParamNestedNoFallthroughRuntime + ( specs + ) where + +import Test.Hspec +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text) +import Yesod.Core + +import YesodCoreTest.RuntimeHarness (assertGet) + +data PNNApp a = PNNApp a + +-- Three-level nesting, generated WITHOUT setNestedRouteFallthrough. A request +-- that matches the grandparent and inner-parent prefixes but no leaf must +-- commit to a 404 (the inner parent is delegated to via its own nested +-- dispatch instance), never fall through. +mkYesodOpts + (setParameterizedSubroute True defaultOpts) + "PNNApp a" + [parseRoutesNoCheck| +/grand GrandR: + /inner InnerR: + /leaf LeafR + /also AlsoR +|] + +instance Yesod (PNNApp a) where + messageLoggerSource = mempty + +handleLeafR :: HandlerFor app String +handleLeafR = pure "LeafR" + +handleAlsoR :: HandlerFor app String +handleAlsoR = pure "AlsoR" + +testRequestIO :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO () +testRequestIO = assertGet (PNNApp ()) + +specs :: Spec +specs = describe "parameterized site, deep nesting, fallthrough DISABLED" $ do + it "matches a leaf under the inner parent (/grand/inner/leaf)" $ + testRequestIO 200 ["grand", "inner", "leaf"] (Just "LeafR") + it "matches the inner parent's other leaf (/grand/inner/also)" $ + testRequestIO 200 ["grand", "inner", "also"] (Just "AlsoR") + it "404s when the grandparent+parent prefix match but no leaf does (/grand/inner/nope)" $ + -- Drives the delegated ResourceParent no-fallthrough arm: GrandR's + -- nested instance dispatches to InnerR's nested instance, which returns + -- Nothing for "nope"; that must become a committed 404. + testRequestIO 404 ["grand", "inner", "nope"] Nothing + it "404s when only the grandparent prefix matches (/grand/nope)" $ + testRequestIO 404 ["grand", "nope"] Nothing diff --git a/test/YesodCoreTest/ParamNoExplicitArgs.hs b/test/YesodCoreTest/ParamNoExplicitArgs.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamNoExplicitArgs.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Regression pin for invoking @mkYesod@ on a *parameterized* foundation +-- /without/ writing its explicit type argument (here @mkYesod "PNoArgs"@ for +-- @data PNoArgs a@). The reified arity is filled with a fresh type variable, +-- and that fill var must travel in the 'TyArgs' handed to 'discoveryMode' / +-- the generators — otherwise the site is misclassified as monomorphic and +-- emits ill-scoped nested instances (a 1.6 -> 1.7 regression). With the fix it +-- stays on the backwards-compatible inline path. The build is the assertion; +-- the WAI rows confirm it still dispatches. +module YesodCoreTest.ParamNoExplicitArgs + ( specs + ) where + +import Data.Text (Text) +import Test.Hspec +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Types as H +import Yesod.Core + +import YesodCoreTest.RuntimeHarness (assertRequestFor) + +-- One type argument, but the splice below names only "PNoArgs" (no @a@). +data PNoArgs a = PNoArgs + +-- @CatchAllR@ overlaps @SubParentR@'s prefix (both start with @sub@), so its +-- @!@ turns overlap checking off for it. It is placed AFTER the parent on +-- purpose: under the historical (1.6) inline @parseRoute@ semantics a path that +-- matches the @sub@ prefix but misses every child must COMMIT at the parent and +-- return 'Nothing', NOT fall through to this later, lower-priority sibling. That +-- is exactly what inline @dispatch@ does (404), so @parseRoute@ has to agree. +mkYesod "PNoArgs" [parseRoutes| +/ HomeR GET +/sub SubParentR: + / SubHomeR GET +!/sub/#Text CatchAllR GET +|] + +instance Yesod (PNoArgs a) where + messageLoggerSource = mempty + +getHomeR :: HandlerFor (PNoArgs a) Text +getHomeR = pure "home" + +getSubHomeR :: HandlerFor (PNoArgs a) Text +getSubHomeR = pure "subHome" + +getCatchAllR :: Text -> HandlerFor (PNoArgs a) Text +getCatchAllR _ = pure "catchAll" + +testRequestIO + :: HasCallStack + => Int + -> [Text] + -> H.Method + -> Maybe L.ByteString + -> IO () +testRequestIO status path method mexpected = + assertRequestFor (PNoArgs :: PNoArgs ()) method status path mexpected + +specs :: Spec +specs = describe "parameterized foundation invoked without explicit type args" $ do + it "static leaf dispatches" $ + testRequestIO 200 [] "GET" (Just "home") + it "inlined nested leaf dispatches" $ + testRequestIO 200 ["sub"] "GET" (Just "subHome") + it "404 on unknown nested suffix (dispatch commits at the parent prefix)" $ + testRequestIO 404 ["sub", "oops"] "GET" Nothing + it "parseRoute commits at the parent prefix: a child miss is Nothing, not the later overlapping sibling" $ + -- The regression: with overlap checking off the flat inline codegen let + -- this fall through to @CatchAllR@, so parseRoute returned @Just + -- (CatchAllR "oops")@ while dispatch returned 404 — they disagreed for + -- the same request. Commit-on-parent-prefix makes parseRoute agree. + (parseRoute (["sub", "oops"], []) :: Maybe (Route (PNoArgs ()))) + `shouldBe` Nothing + it "parseRoute still reaches a matching child under the parent prefix" $ + (parseRoute (["sub"], []) :: Maybe (Route (PNoArgs ()))) + `shouldBe` Just (SubParentR SubHomeR) diff --git a/test/YesodCoreTest/ParamNoFallthroughRuntime.hs b/test/YesodCoreTest/ParamNoFallthroughRuntime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamNoFallthroughRuntime.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | The negative counterpart to "YesodCoreTest.ParamFallthroughRuntime". +-- +-- That module exercises nested-route fallthrough with the flag /enabled/ — +-- every assertion expects fallthrough to succeed. This module builds the same +-- overlapping-@\/foo@ parents *without* 'setNestedRouteFallthrough', and +-- asserts a 404 exactly where the enabled version falls through to a later +-- same-prefix parent. Without this, a regression that made nested fallthrough +-- always-on (ignoring 'roNestedRouteFallthrough') would pass every test. +module YesodCoreTest.ParamNoFallthroughRuntime + ( specs + ) where + +import Test.Hspec +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text) +import Yesod.Core + +import YesodCoreTest.RuntimeHarness (assertGet) + +data PNApp a = PNApp a + +-- Same routes as ParamFallthroughRuntime's first two parents, but generated +-- WITHOUT setNestedRouteFallthrough: the first parent that matches the @/foo@ +-- prefix is committed to, so a path its children can't match 404s rather than +-- falling through to the next @/foo@ parent. +mkYesodOpts + (setParameterizedSubroute True defaultOpts) + "PNApp a" + [parseRoutesNoCheck| +/foo FirstFooR: + / FooIndexR + /neat FooNeatR + +/foo SecondFooR: + / NeverFiresR + /other OtherR +|] + +instance Yesod (PNApp a) where + messageLoggerSource = mempty + +handleFooIndexR :: HandlerFor app String +handleFooIndexR = pure "FooIndexR" + +handleFooNeatR :: HandlerFor app String +handleFooNeatR = pure "FooNeatR" + +handleNeverFiresR :: HandlerFor app String +handleNeverFiresR = pure "NeverFiresR" + +handleOtherR :: HandlerFor app String +handleOtherR = pure "OtherR" + +testRequestIO :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO () +testRequestIO = assertGet (PNApp ()) + +specs :: Spec +specs = describe "parameterized site, nested-route fallthrough DISABLED" $ do + it "still matches the first parent's index (FooIndexR at /foo)" $ + testRequestIO 200 ["foo"] (Just "FooIndexR") + it "still matches a child of the first parent (FooNeatR at /foo/neat)" $ + testRequestIO 200 ["foo", "neat"] (Just "FooNeatR") + it "404s instead of falling through to a later same-prefix parent (/foo/other)" $ + -- With fallthrough this is OtherR (200); without it, the first /foo + -- parent commits and its children don't match "other". + testRequestIO 404 ["foo", "other"] Nothing diff --git a/test/YesodCoreTest/ParamSubsite/Data.hs b/test/YesodCoreTest/ParamSubsite/Data.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamSubsite/Data.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Opt-in counterpart to "YesodCoreTest.ParameterizedSubData": this subsite +-- enables parameterized subroutes via +-- @'mkYesodSubDataOpts' ('setParameterizedSubroute' 'True' ...)@. With the +-- flag on, the nested subroute datatype 'PNestedR' carries the subsite's type +-- parameter (kind @Type -> Type@), so the threaded constraints / associated +-- type families stay well-scoped. This proves that opting a /subsite/ into +-- parameterized subroutes actually parameterizes its subroutes. +module YesodCoreTest.ParamSubsite.Data where + +import Yesod.Core + +type RouteConstraints t = (Eq t, Read t, Show t, PathPiece t) + +class (RouteConstraints (PAssoc subsite)) => PClass subsite master | subsite -> master where + type PAssoc subsite + pValue :: subsite -> master -> String + +newtype PSub subsite = PSub subsite + +mkYesodSubDataOpts (setParameterizedSubroute True defaultOpts) + "(PClass subsite master) => PSub subsite" [parseRoutes| +/ PHomeR GET +/item/#Int PItemR GET +!/#{PAssoc subsite}/nested PNestedR: + / PNestedHomeR GET + /detail/#Int PNestedDetailR GET +|] + +-- | Opt-in kind guard: with parameterized subroutes enabled, the nested +-- subroute datatype is parameterized over the subsite. This signature only +-- compiles if 'PNestedR' has kind @Type -> Type@. +_pNestedRParamGuard :: PNestedR subsite -> PNestedR subsite +_pNestedRParamGuard = id diff --git a/test/YesodCoreTest/ParamSubsite/InstanceRuntime.hs b/test/YesodCoreTest/ParamSubsite/InstanceRuntime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamSubsite/InstanceRuntime.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Runtime coverage for 'mkYesodSubDispatchInstance' (the public convenience +-- that generates both the @YesodSubDispatch@ instance and the +-- @YesodSubDispatchNested@ instances for a parameterized subsite). The +-- function had **no** in-repo test before; this exercises the happy path — +-- a parameterized subsite whose subroutes are parameterized +-- ('setParameterizedSubroute') — end to end (compile + WAI dispatch + route +-- round-trip). +-- +-- The misuse case (parameterized subsite + unparameterized nested datatype) +-- is a compile error by design, so it is covered by the pure unit test for +-- 'checkNestedSubArity' in @Route.SubDispatchAritySpec@ rather than here. +module YesodCoreTest.ParamSubsite.InstanceRuntime + ( specs + ) where + +import Data.Text (Text) +import Test.Hspec +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Types as H +import Yesod.Core +import Yesod.Core.Dispatch (toWaiApp, mkYesodSubDispatchInstance) + +import YesodCoreTest.ParamSubsite.Data +import YesodCoreTest.RuntimeHarness (assertRequestFor) + +-- | Concrete instantiation of the parameterized subsite. +data ConcretePSub = ConcretePSub + +instance PClass ConcretePSub App where + type PAssoc ConcretePSub = Text + pValue _ _ = "value" + +type ConcretePSubT = PSub ConcretePSub + +data App = App + +-- Handlers for the subsite. The nested handlers receive the parent's +-- 'PAssoc' dynamic, exactly as for any other nested route. +getPHomeR :: SubHandlerFor (PSub subsite) master Text +getPHomeR = pure "pHome" + +getPItemR :: Int -> SubHandlerFor (PSub subsite) master Text +getPItemR _ = pure "pItem" + +getPNestedHomeR :: PAssoc subsite -> SubHandlerFor (PSub subsite) master Text +getPNestedHomeR _ = pure "pNestedHome" + +getPNestedDetailR :: PAssoc subsite -> Int -> SubHandlerFor (PSub subsite) master Text +getPNestedDetailR _ _ = pure "pNestedDetail" + +-- The API under test: generate the YesodSubDispatch + YesodSubDispatchNested +-- instances for the parameterized subsite. Placed before 'mkYesod' so the +-- master dispatch can see the generated subsite instances. +mkYesodSubDispatchInstance "(PClass subsite master) => PSub subsite" resourcesPSub + +mkYesod "App" [parseRoutes| +/ HomeR GET +/p PSubR ConcretePSubT getP +|] + +instance Yesod App where + messageLoggerSource = mempty + +getHomeR :: Handler Text +getHomeR = pure "home" + +getP :: App -> ConcretePSubT +getP _ = PSub ConcretePSub + +sampleRoutes :: [Route ConcretePSubT] +sampleRoutes = + [ PHomeR + , PItemR 7 + , PNestedR "abc" PNestedHomeR + , PNestedR "abc" (PNestedDetailR 9) + ] + +testRequestIO + :: HasCallStack + => Int + -> [Text] + -> H.Method + -> Maybe L.ByteString + -> IO () +testRequestIO status path method mexpected = + assertRequestFor App method status path mexpected + +specs :: Spec +specs = describe "mkYesodSubDispatchInstance (parameterized subsite, opt-in subroutes)" $ do + describe "parseRoute . renderRoute round-trips" $ + mapM_ + (\r -> it (show r) $ parseRoute (renderRoute r) `shouldBe` Just r) + sampleRoutes + + describe "WAI dispatch (subsite mounted at /p)" $ do + it "static leaf (PHomeR)" $ + testRequestIO 200 ["p"] "GET" (Just "pHome") + it "dynamic leaf (PItemR)" $ + testRequestIO 200 ["p", "item", "7"] "GET" (Just "pItem") + it "nested parent home (PNestedR _ PNestedHomeR)" $ + testRequestIO 200 ["p", "abc", "nested"] "GET" (Just "pNestedHome") + it "nested parent dynamic leaf (PNestedR _ (PNestedDetailR _))" $ + testRequestIO 200 ["p", "abc", "nested", "detail", "9"] "GET" (Just "pNestedDetail") + it "404 on unknown nested suffix" $ + testRequestIO 404 ["p", "abc", "nested", "oops"] "GET" Nothing + it "405 on wrong method" $ + testRequestIO 405 ["p", "abc", "nested"] "POST" Nothing diff --git a/test/YesodCoreTest/ParamSubsite/SplitNested.hs b/test/YesodCoreTest/ParamSubsite/SplitNested.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamSubsite/SplitNested.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Split-out dispatch module for the *parameterized* subsite's nested +-- 'PNestedR' fragment. This is the parameterized counterpart to +-- "YesodCoreTest.SplitSubsite.NestedR": the subsite carries a type parameter, +-- so the subroute datatype 'PNestedR' is itself parameterized (kind +-- @Type -> Type@), and the subsite's type argument must be threaded through +-- 'mkNestedSubDispatchInstance' as 'SomeTyArgs'. +-- +-- Crucially, the nested handlers ('getPNestedHomeR', 'getPNestedDetailR') live +-- ONLY here, not in the module that defines the parent 'YesodSubDispatch' +-- instance. So that parent splice can compile only by *delegating* to the +-- 'YesodSubDispatchNested' instance generated here (via 'isInstance') — if it +-- tried to inline the nested routes it would reference handlers not in scope. +-- A successful build is therefore proof that the cross-module split works for +-- a parameterized subsite, exercising the @SomeTyArgs@ / @applyTyArgs@ branches +-- of the dispatch codegen that were previously untested. +module YesodCoreTest.ParamSubsite.SplitNested () where + +import Yesod.Core +import Yesod.Core.Dispatch + (mkNestedSubDispatchInstance, TyArgs(..)) +import Language.Haskell.TH (Type(..), mkName) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Text (Text) + +import YesodCoreTest.ParamSubsite.Data + +getPNestedHomeR :: PAssoc subsite -> SubHandlerFor (PSub subsite) master Text +getPNestedHomeR _ = pure "pNestedHome" + +getPNestedDetailR :: PAssoc subsite -> Int -> SubHandlerFor (PSub subsite) master Text +getPNestedDetailR _ _ = pure "pNestedDetail" + +-- Generate @YesodSubDispatchNested (PNestedR subsite)@ in this separate module, +-- with the subsite's type argument applied. +-- +-- The 'Cxt' and 'TyArgs' are built manually (rather than parsed from a string +-- like @"(PClass subsite master) => PSub subsite"@) because structured +-- arguments are 'mkNestedSubDispatchInstance''s interface: the string parser +-- belongs to 'mkYesodSubDispatchInstance', the whole-subsite entry point, +-- which does this same construction internally after parsing. A split-out +-- fragment module addresses one nested datatype directly, so it supplies the +-- pieces directly; what is written here is exactly what the parent entry +-- point would thread through for that name string. +$(do + let subsite = mkName "subsite" + master = mkName "master" + cxt = [ ConT (mkName "PClass") `AppT` VarT subsite `AppT` VarT master ] + tyargs = SomeTyArgs ((VarT subsite, subsite) :| []) + mkNestedSubDispatchInstance + (setParameterizedSubroute True defaultOpts) + "PNestedR" + cxt + tyargs + return + resourcesPSub) diff --git a/test/YesodCoreTest/ParamSubsite/SplitRuntime.hs b/test/YesodCoreTest/ParamSubsite/SplitRuntime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamSubsite/SplitRuntime.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Runtime coverage for a *parameterized* subsite whose nested routes are +-- /split across modules/ — the combination that had no test before (split was +-- monomorphic-only; parameterized nested-discovery was single-module-only). +-- +-- The parent @YesodSubDispatch (PSub subsite) master@ instance is generated +-- here with 'mkYesodSubDispatch', but the nested 'PNestedR' handlers and its +-- 'YesodSubDispatchNested' instance live in the separately compiled +-- "YesodCoreTest.ParamSubsite.SplitNested". Because those handlers are NOT in scope +-- here, this module compiles only if the parent splice *delegates* to the +-- external nested instance rather than inlining it — so the build itself is +-- the split-delegation assertion, and the WAI tests confirm it dispatches. +module YesodCoreTest.ParamSubsite.SplitRuntime + ( specs + ) where + +import Data.Text (Text) +import Test.Hspec +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Types as H +import Yesod.Core + +import YesodCoreTest.ParamSubsite.Data +import YesodCoreTest.ParamSubsite.SplitNested () -- brings the split nested instance into scope +import YesodCoreTest.RuntimeHarness (assertRequestFor) + +-- | Concrete instantiation of the parameterized subsite. +data ConcretePSub = ConcretePSub + +instance PClass ConcretePSub App where + type PAssoc ConcretePSub = Text + pValue _ _ = "value" + +type ConcretePSubT = PSub ConcretePSub + +data App = App + +-- Only the FLAT subsite handlers live here; the nested ones are deliberately +-- absent (see module haddock). +getPHomeR :: SubHandlerFor (PSub subsite) master Text +getPHomeR = pure "pHome" + +getPItemR :: Int -> SubHandlerFor (PSub subsite) master Text +getPItemR _ = pure "pItem" + +-- The parent dispatch. Generated in THIS module (separately from the nested +-- 'PNestedR' instance), so its 'mkYesodSubDispatch' splice must delegate to the +-- imported 'YesodSubDispatchNested (PNestedR subsite)' instance. +instance PClass subsite master => YesodSubDispatch (PSub subsite) master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesPSub) + +mkYesod "App" [parseRoutes| +/ HomeR GET +/p PSubR ConcretePSubT getP +|] + +instance Yesod App where + messageLoggerSource = mempty + +getHomeR :: Handler Text +getHomeR = pure "home" + +getP :: App -> ConcretePSubT +getP _ = PSub ConcretePSub + +sampleRoutes :: [Route ConcretePSubT] +sampleRoutes = + [ PHomeR + , PItemR 7 + , PNestedR "abc" PNestedHomeR + , PNestedR "abc" (PNestedDetailR 9) + ] + +testRequestIO + :: HasCallStack + => Int + -> [Text] + -> H.Method + -> Maybe L.ByteString + -> IO () +testRequestIO status path method mexpected = + assertRequestFor App method status path mexpected + +specs :: Spec +specs = describe "parameterized subsite, nested routes split across modules" $ do + describe "parseRoute . renderRoute round-trips" $ + mapM_ + (\r -> it (show r) $ parseRoute (renderRoute r) `shouldBe` Just r) + sampleRoutes + + describe "WAI dispatch (parent delegates to the split nested instance)" $ do + it "static leaf (PHomeR)" $ + testRequestIO 200 ["p"] "GET" (Just "pHome") + it "dynamic leaf (PItemR)" $ + testRequestIO 200 ["p", "item", "7"] "GET" (Just "pItem") + it "nested parent home (delegated PNestedHomeR)" $ + testRequestIO 200 ["p", "abc", "nested"] "GET" (Just "pNestedHome") + it "nested parent dynamic leaf (delegated PNestedDetailR)" $ + testRequestIO 200 ["p", "abc", "nested", "detail", "9"] "GET" (Just "pNestedDetail") + it "404 on unknown nested suffix" $ + testRequestIO 404 ["p", "abc", "nested", "oops"] "GET" Nothing + it "405 on wrong method" $ + testRequestIO 405 ["p", "abc", "nested"] "POST" Nothing diff --git a/test/YesodCoreTest/ParamTopLevelRuntime.hs b/test/YesodCoreTest/ParamTopLevelRuntime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParamTopLevelRuntime.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Runtime coverage for a *top-level* parameterized site that opts into +-- nested route discovery ('setParameterizedSubroute'). Existing coverage of +-- this combination ("YesodCoreTest.ParameterizedSite.SubRoute") only fires a +-- single request per route and never round-trips or checks error statuses; +-- this exercises the same opt-in top-level path with full +-- @parseRoute . renderRoute@ round-trips plus 404/405 cases. +module YesodCoreTest.ParamTopLevelRuntime + ( specs + ) where + +import Data.Text (Text) +import Test.Hspec +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Types as H +import Yesod.Core + +import YesodCoreTest.RuntimeHarness (assertRequestFor) + +-- A phantom-parameterized top-level site. With 'setParameterizedSubroute' +-- enabled, the nested subroute datatype 'SubParentR' carries the parameter +-- (kind @Type -> Type@), so this drives the NestedDiscovery codegen path. +data Poly a = Poly a + +mkYesodOpts (setParameterizedSubroute True defaultOpts) "Poly a" [parseRoutes| +/ HomeR GET +/item/#Int ItemR GET +/sub SubParentR: + / SubHomeR GET + /detail/#Int SubDetailR GET +|] + +instance Yesod (Poly a) where + messageLoggerSource = mempty + +getHomeR :: HandlerFor (Poly a) Text +getHomeR = pure "home" + +getItemR :: Int -> HandlerFor (Poly a) Text +getItemR _ = pure "item" + +getSubHomeR :: HandlerFor (Poly a) Text +getSubHomeR = pure "subHome" + +getSubDetailR :: Int -> HandlerFor (Poly a) Text +getSubDetailR _ = pure "subDetail" + +sampleRoutes :: [Route (Poly ())] +sampleRoutes = + [ HomeR + , ItemR 7 + , SubParentR SubHomeR + , SubParentR (SubDetailR 9) + ] + +testRequestIO + :: HasCallStack + => Int + -> [Text] + -> H.Method + -> Maybe L.ByteString + -> IO () +testRequestIO status path method mexpected = + assertRequestFor (Poly ()) method status path mexpected + +specs :: Spec +specs = describe "top-level parameterized site, opted into nested discovery" $ do + describe "parseRoute . renderRoute round-trips" $ + mapM_ + (\r -> it (show r) $ parseRoute (renderRoute r) `shouldBe` Just r) + sampleRoutes + + describe "WAI dispatch" $ do + it "static leaf (HomeR)" $ + testRequestIO 200 [] "GET" (Just "home") + it "dynamic leaf (ItemR)" $ + testRequestIO 200 ["item", "7"] "GET" (Just "item") + it "nested parent home (SubParentR SubHomeR)" $ + testRequestIO 200 ["sub"] "GET" (Just "subHome") + it "nested parent dynamic leaf (SubParentR (SubDetailR _))" $ + testRequestIO 200 ["sub", "detail", "9"] "GET" (Just "subDetail") + it "404 on unknown nested suffix" $ + testRequestIO 404 ["sub", "detail", "9", "oops"] "GET" Nothing + it "405 on wrong method" $ + testRequestIO 405 ["sub"] "POST" Nothing diff --git a/test/YesodCoreTest/ParameterizedSite/SubRoute.hs b/test/YesodCoreTest/ParameterizedSite/SubRoute.hs --- a/test/YesodCoreTest/ParameterizedSite/SubRoute.hs +++ b/test/YesodCoreTest/ParameterizedSite/SubRoute.hs @@ -3,6 +3,8 @@ , OverloadedStrings, StandaloneDeriving, FlexibleInstances, FlexibleContexts , ViewPatterns, UndecidableInstances, ConstraintKinds #-} + + module YesodCoreTest.ParameterizedSite.SubRoute where import Yesod.Core @@ -46,6 +48,16 @@ deriving (Eq, Show, Read) which clearly doesn't work, as `p` is not in scope. -} + +-- | Opt-in guard (the counterpart to the backwards-compat guard in +-- "YesodCoreTest.ParameterizedSubDispatch"). With 'setParameterizedSubroute' +-- enabled, the nested subroute datatype /does/ carry the parent's type +-- parameters — here 'EditorR' has kind @Type -> Type -> Type@ — so the +-- threaded constraints stay well-scoped. This signature only compiles if the +-- opt-in still parameterizes the subroute, proving the nested-discovery +-- feature remains available behind the flag. +_editorRParamGuard :: EditorR p v -> EditorR p v +_editorRParamGuard = id instance SiteClass a => Yesod (SubRoute a v) diff --git a/test/YesodCoreTest/ParameterizedSubData.hs b/test/YesodCoreTest/ParameterizedSubData.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParameterizedSubData.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FunctionalDependencies #-} +-- ^ Useful for debugging generated code; can be removed once stable + +-- | Test case for mkYesodSubData and mkYesodSubDispatch with +-- parameterized/constrained types. Reproduces bugs reported by +-- l0neGamer on PR #1887: +-- +-- 1. mkYesodSubData with a constrained type like +-- @"(SomeClass subsite master) => SubsiteData subsite"@ +-- where 'master' appears in the context but NOT as a type parameter +-- of the subsite, produces "Out of scope type variable" errors in +-- family instances. +-- +-- 2. mkYesodSubDispatch with the same setup produces "Expecting one +-- more argument to 'NestedR'" because isInstance checks and Proxy +-- types weren't fully applied. See ParameterizedSubDispatch.hs. +module YesodCoreTest.ParameterizedSubData where + +import Yesod.Core + +type RouteConstraints t = (Eq t, Read t, Show t, PathPiece t) + +-- | A multi-param type class where 'master' is NOT a parameter of the +-- subsite type, mimicking the pattern: +-- @mkYesodSubData "(SubsiteClass subsite master) => SubsiteData subsite"@ +-- The fundep ensures 'master' is determined by 'subsite', which is +-- typical for real-world subsite classes. +class (RouteConstraints (AssocType subsite)) => ParamSubsiteClass subsite master | subsite -> master where + type AssocType subsite + getSubsiteValue :: subsite -> master -> String + +newtype ParamSubsite subsite = ParamSubsite subsite + +mkYesodSubData "(ParamSubsiteClass subsite master) => ParamSubsite subsite" [parseRoutes| +/ ParamSubHomeR GET +/item/#Int ParamSubItemR GET +!/#{AssocType subsite}/nested NestedR: + / NestedHomeR GET + /detail/#Int NestedDetailR GET +|] diff --git a/test/YesodCoreTest/ParameterizedSubDispatch.hs b/test/YesodCoreTest/ParameterizedSubDispatch.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParameterizedSubDispatch.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Test mkYesodSubDispatch with parameterized/constrained types. +-- This exercises the Dispatch TH code path for parameterized subsites. +-- +-- Tests two subsites: +-- 1. ParamSubDispatch (from Data submodule) - simple parameterized subsite +-- 2. ParamSubsite (from ParameterizedSubData) - with associated types, +-- dynamic pieces in nested route parents, and ConstraintKinds +module YesodCoreTest.ParameterizedSubDispatch where + +import Yesod.Core +import Data.Text (Text) +import YesodCoreTest.ParameterizedSubDispatch.Data +import YesodCoreTest.ParameterizedSubData + +-- Handlers for ParamSubDispatch (simple parameterized subsite) +getParamDispHomeR :: SubHandlerFor (ParamSubDispatch subsite) master Text +getParamDispHomeR = pure "home" + +getParamDispItemR :: Int -> SubHandlerFor (ParamSubDispatch subsite) master Text +getParamDispItemR _ = pure "item" + +instance ParamSubDispatchClass subsite master => YesodSubDispatch (ParamSubDispatch subsite) master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesParamSubDispatch) + +-- Handlers for ParamSubsite (with associated types and nested routes) +getParamSubHomeR :: SubHandlerFor (ParamSubsite subsite) master Text +getParamSubHomeR = pure "paramSubHome" + +getParamSubItemR :: Int -> SubHandlerFor (ParamSubsite subsite) master Text +getParamSubItemR _ = pure "paramSubItem" + +getNestedHomeR :: AssocType subsite -> SubHandlerFor (ParamSubsite subsite) master Text +getNestedHomeR _ = pure "nestedHome" + +getNestedDetailR :: AssocType subsite -> Int -> SubHandlerFor (ParamSubsite subsite) master Text +getNestedDetailR _ _ = pure "nestedDetail" + +instance + ( ParamSubsiteClass subsite master + ) => YesodSubDispatch (ParamSubsite subsite) master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesParamSubsite) + +-- | Backwards-compatibility guard for the reported regression. +-- +-- By default ('defaultOpts', as used by 'mkYesodSubData'), nested subroute +-- datatypes must remain *unparameterized* — kind 'Type' — exactly as +-- pre-nested-discovery Yesod generated them. The reported breakage was that +-- the branch silently gave them the parent's type parameter (kind +-- @Type -> Type@), which broke any downstream type signature mentioning the +-- subroute. +-- +-- This signature only compiles if 'NestedR' has kind 'Type'. If the default +-- ever regresses to parameterizing subroutes, 'NestedR' would have kind +-- @Type -> Type@ and this would fail with a kind error — turning the +-- downstream breakage into a local, in-repo test failure. +_nestedRArityGuard :: NestedR -> NestedR +_nestedRArityGuard = id diff --git a/test/YesodCoreTest/ParameterizedSubDispatch/Data.hs b/test/YesodCoreTest/ParameterizedSubDispatch/Data.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParameterizedSubDispatch/Data.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Route data for a parameterized subsite used by +-- ParameterizedSubDispatch to test mkYesodSubDispatch. +module YesodCoreTest.ParameterizedSubDispatch.Data where + +import Yesod.Core + +class ParamSubDispatchClass subsite master | subsite -> master where + getDispatchValue :: subsite -> master -> String + +data ParamSubDispatch subsite = ParamSubDispatch subsite + +mkYesodSubData "(ParamSubDispatchClass subsite master) => ParamSubDispatch subsite" [parseRoutes| +/ ParamDispHomeR GET +/item/#Int ParamDispItemR GET +|] diff --git a/test/YesodCoreTest/ParameterizedSubDispatchRuntime.hs b/test/YesodCoreTest/ParameterizedSubDispatchRuntime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParameterizedSubDispatchRuntime.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Runtime coverage for the backwards-compatible (opt-out) inline +-- nested-route codegen. +-- +-- The modules "YesodCoreTest.ParameterizedSubData" / +-- "YesodCoreTest.ParameterizedSubDispatch" only exercise the parameterized +-- /opt-out/ path at *compile time* (data + dispatch instances, no runtime +-- assertions). This module gives the same shape a concrete instantiation and +-- actually exercises it at runtime: +-- +-- * 'parseRoute' . 'renderRoute' round-trips for every constructor, and +-- * WAI dispatch returns the right status + body for each path, +-- +-- covering the static, dynamic, and (dynamically-keyed) nested-parent inline +-- arms — the path-piece ordering, parent-constructor nesting and @dyns@ +-- handling that previously had no runtime guard. +module YesodCoreTest.ParameterizedSubDispatchRuntime + ( specs + ) where + +import Data.Text (Text) +import Test.Hspec +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Types as H +import Yesod.Core +import Yesod.Core.Dispatch (toWaiApp) + +import YesodCoreTest.ParameterizedSubData +import YesodCoreTest.ParameterizedSubDispatch () +import YesodCoreTest.ParameterizedSubDispatchRuntime.Data +import YesodCoreTest.RuntimeHarness (assertRequestFor) + +-- | A concrete subsite for 'ParamSubsite'. Its associated 'AssocType' is +-- 'Text', so the dynamically-keyed nested parent (@!/#{AssocType subsite}@) +-- becomes a plain @Text@ path piece at runtime. +data ConcreteSub = ConcreteSub + +instance ParamSubsiteClass ConcreteSub App where + type AssocType ConcreteSub = Text + getSubsiteValue _ _ = "concrete" + +-- | parseRoutes can only embed a single-token subsite type, so we alias the +-- fully-applied subsites here. +type ConcreteParamSub = ParamSubsite ConcreteSub +type ConcreteBigSub = BigSub () + +data App = App + +mkYesod "App" [parseRoutes| +/ HomeR GET +/sub ParamSubR ConcreteParamSub getSub +/big BigSubR ConcreteBigSub getBig +|] + +instance Yesod App where + messageLoggerSource = mempty + +getHomeR :: Handler Text +getHomeR = pure "home" + +getSub :: App -> ConcreteParamSub +getSub _ = ParamSubsite ConcreteSub + +getBig :: App -> ConcreteBigSub +getBig _ = BigSub () + +-- Dispatch + handlers for the BigSub / ChildSub subsites. +instance YesodSubDispatch (BigSub a) master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesBigSub) + +instance YesodSubDispatch ChildSub master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesChildSub) + +getBigItemR :: Int -> SubHandlerFor (BigSub a) master Text +getBigItemR _ = pure "bigItem" + +getBigMultiR :: [Text] -> SubHandlerFor (BigSub a) master Text +getBigMultiR _ = pure "bigMulti" + +getWrapHomeR :: Int -> SubHandlerFor (BigSub a) master Text +getWrapHomeR _ = pure "wrapHome" + +getWrapDetailR :: Int -> Int -> SubHandlerFor (BigSub a) master Text +getWrapDetailR _ _ = pure "wrapDetail" + +getChildHomeR :: SubHandlerFor ChildSub master Text +getChildHomeR = pure "childHome" + +getChildXR :: Int -> SubHandlerFor ChildSub master Text +getChildXR _ = pure "childX" + +-- | Every constructor of the parameterized subsite's route, instantiated at +-- the concrete subsite. +sampleRoutes :: [Route ConcreteParamSub] +sampleRoutes = + [ ParamSubHomeR + , ParamSubItemR 7 + , NestedR "abc" NestedHomeR + , NestedR "abc" (NestedDetailR 9) + ] + +-- | Routes for 'BigSub', covering a multipiece leaf and a subsite leaf nested +-- under a 'ResourceParent'. +bigSampleRoutes :: [Route ConcreteBigSub] +bigSampleRoutes = + [ BigItemR 3 + , BigMultiR ["a", "b", "c"] + , BigMultiR [] + , WrapR 5 WrapHomeR + , WrapR 5 (WrapDetailR 9) + , EmbedParentR (ChildR ChildHomeR) + , EmbedParentR (ChildR (ChildXR 9)) + ] + +testRequestIO + :: HasCallStack + => Int -- ^ expected http status code + -> [Text] -- ^ pathInfo + -> H.Method -- ^ request method + -> Maybe L.ByteString -- ^ expected body (Nothing = don't check) + -> IO () +testRequestIO status path method mexpected = + assertRequestFor App method status path mexpected + +specs :: Spec +specs = describe "opt-out (backwards-compat) parameterized nested routes" $ do + describe "parseRoute . renderRoute round-trips" $ do + mapM_ + (\r -> it (show r) $ + parseRoute (renderRoute r) `shouldBe` Just r) + sampleRoutes + mapM_ + (\r -> it (show r) $ + parseRoute (renderRoute r) `shouldBe` Just r) + bigSampleRoutes + + describe "WAI dispatch (subsite mounted at /sub)" $ do + it "static leaf (ParamSubHomeR)" $ + testRequestIO 200 ["sub"] "GET" (Just "paramSubHome") + it "dynamic leaf (ParamSubItemR)" $ + testRequestIO 200 ["sub", "item", "7"] "GET" (Just "paramSubItem") + it "nested parent home (NestedR _ NestedHomeR)" $ + testRequestIO 200 ["sub", "abc", "nested"] "GET" (Just "nestedHome") + it "nested parent dynamic leaf (NestedR _ (NestedDetailR _))" $ + testRequestIO 200 ["sub", "abc", "nested", "detail", "9"] "GET" (Just "nestedDetail") + it "404 on unknown nested suffix" $ + testRequestIO 404 ["sub", "abc", "nested", "oops"] "GET" Nothing + it "405 on wrong method for nested leaf" $ + testRequestIO 405 ["sub", "abc", "nested"] "POST" Nothing + it "404 on malformed dynamic leaf piece (#Int given non-integer)" $ + testRequestIO 404 ["sub", "item", "notanint"] "GET" Nothing + it "404 on malformed dynamic nested-leaf piece (NestedDetailR #Int)" $ + testRequestIO 404 ["sub", "abc", "nested", "detail", "notanint"] "GET" Nothing + + describe "WAI dispatch (BigSub mounted at /big)" $ do + it "dynamic leaf (BigItemR)" $ + testRequestIO 200 ["big", "item", "3"] "GET" (Just "bigItem") + it "multipiece leaf (BigMultiR)" $ + testRequestIO 200 ["big", "multi", "a", "b", "c"] "GET" (Just "bigMulti") + it "multipiece leaf, empty tail (BigMultiR [])" $ + testRequestIO 200 ["big", "multi"] "GET" (Just "bigMulti") + it "nested parent home (WrapR _ WrapHomeR)" $ + testRequestIO 200 ["big", "wrap", "5"] "GET" (Just "wrapHome") + it "nested parent dynamic leaf (WrapR _ (WrapDetailR _))" $ + testRequestIO 200 ["big", "wrap", "5", "detail", "9"] "GET" (Just "wrapDetail") + it "subsite leaf nested under parent, home (EmbedParentR (ChildR ChildHomeR))" $ + testRequestIO 200 ["big", "embed", "sub"] "GET" (Just "childHome") + it "subsite leaf nested under parent, dynamic (EmbedParentR (ChildR (ChildXR _)))" $ + testRequestIO 200 ["big", "embed", "sub", "x", "9"] "GET" (Just "childX") + it "404 on malformed dynamic parent key (WrapR #Int given non-integer)" $ + testRequestIO 404 ["big", "wrap", "notanint"] "GET" Nothing diff --git a/test/YesodCoreTest/ParameterizedSubDispatchRuntime/Data.hs b/test/YesodCoreTest/ParameterizedSubDispatchRuntime/Data.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParameterizedSubDispatchRuntime/Data.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Route data for the runtime opt-out coverage in +-- "YesodCoreTest.ParameterizedSubDispatchRuntime". Kept in its own module so +-- the 'mkYesodSubDispatch' splices there can refer to the @resources*@ values +-- generated here (TH stage restriction). +module YesodCoreTest.ParameterizedSubDispatchRuntime.Data where + +import Yesod.Core +import Data.Text (Text) + +-- | A monomorphic leaf subsite, embedded under a 'ResourceParent' of 'BigSub' +-- to exercise the inline @Subsite@ arm +-- ('generateParseRouteClausesInline' in Yesod.Routes.TH.ParseRoute). +data ChildSub = ChildSub + +mkYesodSubData "ChildSub" [parseRoutes| +/ ChildHomeR GET +/x/#Int ChildXR GET +|] + +-- | A parameterized (hence opt-out) subsite that covers a multipiece leaf and +-- a subsite leaf nested under a 'ResourceParent'. The type parameter @a@ is +-- phantom — its only job is to make @tyargs@ non-empty so the +-- backwards-compatible inline path is taken. +newtype BigSub a = BigSub a + +mkYesodSubData "BigSub a" [parseRoutes| +/item/#Int BigItemR GET +/multi/+[Text] BigMultiR GET +/wrap/#Int WrapR: + / WrapHomeR GET + /detail/#Int WrapDetailR GET +/embed EmbedParentR: + /sub ChildR ChildSub getChildSub +|] + +getChildSub :: BigSub a -> ChildSub +getChildSub _ = ChildSub diff --git a/test/YesodCoreTest/RenderRouteSpec.hs b/test/YesodCoreTest/RenderRouteSpec.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/RenderRouteSpec.hs @@ -0,0 +1,51 @@ +{-# language CPP #-} +{-# language TemplateHaskell #-} +{-# language TypeApplications #-} +{-# language OverloadedStrings #-} +{-# language TypeFamilies #-} +{-# language ViewPatterns #-} + +-- | Behavioural @renderRoute@ spec built from a hand-constructed +-- 'ResourceTree' AST (a @ResourceParent@ with one dynamic piece over a leaf) +-- rather than @parseRoutes@, so it pins @mkRenderRouteInstanceOpts@ directly +-- against a known tree. Companion module "YesodCoreTest.RenderRouteSpec.TH" +-- reuses the generated instance from a compile-time splice. +module YesodCoreTest.RenderRouteSpec where + +import Yesod.Routes.TH.Types +import Language.Haskell.TH +import Yesod.Routes.TH.RenderRoute +import Yesod.Routes.Class +import Test.Hspec + +data App = App + +-- Generate the 'RenderRoute' instance for 'App' at compile time, then check +-- 'renderRoute' behaves at runtime (the prod path; the intermediate clause +-- lists are not asserted directly). +do + let int = ConT ''Int + mkRenderRouteInstanceOpts defaultOpts [] NoTyArgs (ConT (mkName "App")) + [ ResourceParent "FirstR" False mempty [Static "first", Dynamic int] + [ ResourceLeaf Resource + { resourceName = "BlahR" + , resourcePieces = [Static "blah"] + , resourceDispatch = Methods + { methodsMulti = Nothing + , methodsMethods = [] + } + , resourceAttrs = [] + , resourceCheck = False + } + ] + ] + +spec :: Spec +spec = do + describe "renderRoute" $ do + it "works on top level" $ do + case renderRoute (FirstR 1 BlahR) of + (["first", "1", "blah"], []) -> + pure @IO () + wrong -> + fail $ "Expected renderRoute to work, but got: " <> show wrong diff --git a/test/YesodCoreTest/RenderRouteSpec/TH.hs b/test/YesodCoreTest/RenderRouteSpec/TH.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/RenderRouteSpec/TH.hs @@ -0,0 +1,32 @@ +{-# language TemplateHaskell #-} +{-# language TypeApplications #-} +{-# language OverloadedStrings #-} +{-# language TypeFamilies #-} +{-# language ViewPatterns #-} + +-- | Compile-time companion to "YesodCoreTest.RenderRouteSpec": reuses that +-- module's generated @RenderRoute App@ instance and @fail@s the splice unless +-- both @renderRoute@ (full route) and @renderRouteNested@ (from the leaf, given +-- the parent's captured arg) reconstruct the same path. Lives apart from the +-- generating module so the instance is in scope when these top-level splices run. +module YesodCoreTest.RenderRouteSpec.TH where + +import Yesod.Routes.Class +import YesodCoreTest.RenderRouteSpec + +do + case renderRoute (FirstR 1 BlahR) of + (["first", "1", "blah"], []) -> + pure () + wrong -> + fail $ "Expecte renderRoute to work, but got: " <> show wrong + + pure [] + +do + case renderRouteNested 1 BlahR of + (["first", "1", "blah"], []) -> + pure [] + wrong -> + fail $ "Expected renderRouteNested to work, but got: " <> show wrong + diff --git a/test/YesodCoreTest/RuntimeHarness.hs b/test/YesodCoreTest/RuntimeHarness.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/RuntimeHarness.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | A single WAI round-trip helper shared by the parameterized / nested +-- dispatch runtime specs. Previously each of those modules carried its own +-- near-identical @testRequestIO@, in two disagreeing styles +-- (@shouldBe@-on-@simpleStatus@ vs. @assertStatus@). This is the one shared +-- harness: it takes the action that builds the WAI app plus the request +-- details, and asserts the response status (and body, when given) using +-- 'assertStatus' / 'assertBody' so a mismatch prints the offending response. +module YesodCoreTest.RuntimeHarness + ( assertRequest + , assertRequestFor + , assertGet + , assertRequestRaw + ) where + +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text) +import Network.Wai (Application, Request, pathInfo, requestMethod) +import Network.Wai.Test +import Test.Hspec (HasCallStack) +import Yesod.Core (Yesod, YesodDispatch, toWaiApp) +import qualified Network.HTTP.Types as H + +-- | Build the WAI app, issue one request at @path@ with @method@, assert the +-- response status, and (when given) assert the body. +assertRequest + :: HasCallStack + => IO Application -- ^ build the WAI app (e.g. @toWaiApp App@) + -> H.Method -- ^ request method + -> Int -- ^ expected status code + -> [Text] -- ^ request path + -> Maybe ByteString -- ^ expected body, if checked + -> IO () +assertRequest mkApp method status path mexpected = do + app <- mkApp + flip runSession app $ do + sres <- request defaultRequest + { pathInfo = path + , requestMethod = method + } + assertStatus status sres + case mexpected of + Nothing -> pure () + Just expected -> assertBody expected sres + +-- | 'assertRequest' specialised to a concrete site: builds the WAI app with +-- 'toWaiApp' for you. This is the shape almost every runtime spec wants, and +-- standardises the argument order (@site → method → status → path → body@) that +-- the per-module @testRequestIO@ wrappers used to spell inconsistently. +assertRequestFor + :: (HasCallStack, Yesod site, YesodDispatch site) + => site -- ^ the site to dispatch against + -> H.Method -- ^ request method + -> Int -- ^ expected status code + -> [Text] -- ^ request path + -> Maybe ByteString -- ^ expected body, if checked + -> IO () +assertRequestFor site = assertRequest (toWaiApp site) + +-- | 'assertRequestFor' fixed to @GET@ — the common case. +assertGet + :: (HasCallStack, Yesod site, YesodDispatch site) + => site -> Int -> [Text] -> Maybe ByteString -> IO () +assertGet site = assertRequestFor site "GET" + +-- | Like 'assertRequest', but issue a fully caller-built 'Request' (e.g. one +-- carrying an @Accept@ header for content negotiation) rather than just a +-- path + method. 'assertStatus'/'assertBody' already print the offending +-- response on a mismatch, so callers don't need their own annotate-on-failure +-- wrapper. +assertRequestRaw + :: HasCallStack + => IO Application -> Request -> Int -> Maybe ByteString -> IO () +assertRequestRaw mkApp req status mexpected = do + app <- mkApp + flip runSession app $ do + sres <- request req + assertStatus status sres + case mexpected of + Nothing -> pure () + Just expected -> assertBody expected sres diff --git a/test/YesodCoreTest/SplitSubsite/Data.hs b/test/YesodCoreTest/SplitSubsite/Data.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/SplitSubsite/Data.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Data module for the split-subsite test. Defines a (non-parameterized) +-- subsite with a nested route, and generates its route datatype, render and +-- parse instances. Because the subsite has no type parameters, the +-- nested-discovery machinery (RenderRouteNested / ParseRouteNested for the +-- nested 'NestedR' fragment) is generated here, so that a separately compiled +-- module can supply the matching 'YesodSubDispatchNested' instance. +module YesodCoreTest.SplitSubsite.Data where + +import Yesod.Core + +data SplitSub = SplitSub + +mkYesodSubData "SplitSub" [parseRoutes| +/ SplitHomeR GET +/nested NestedR: + / NestedHomeR GET + /detail/#Int NestedDetailR GET +|] diff --git a/test/YesodCoreTest/SplitSubsite/NestedR.hs b/test/YesodCoreTest/SplitSubsite/NestedR.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/SplitSubsite/NestedR.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | The split-out dispatch module for the subsite's nested 'NestedR' +-- fragment. The handlers for the nested routes live here, alongside the +-- 'YesodSubDispatchNested' instance generated by 'mkNestedSubDispatchInstance'. +-- +-- Crucially, this module is compiled /separately/ from the module that +-- defines the subsite's top-level 'YesodSubDispatch' instance. That instance's +-- 'mkYesodSubDispatch' splice sees this 'YesodSubDispatchNested' instance via +-- 'isInstance' and delegates to it — exactly the cross-module splitting that +-- "YesodCoreTest.NestedDispatch.Runtime" demonstrates for top-level sites. +module YesodCoreTest.SplitSubsite.NestedR (NestedR(..)) where + +import Yesod.Core +import Yesod.Core.Dispatch + (mkNestedSubDispatchInstance, defaultOpts, TyArgs(..)) +import Data.Text (Text, pack) + +import YesodCoreTest.SplitSubsite.Data + +getNestedHomeR :: SubHandlerFor SplitSub master Text +getNestedHomeR = pure "nestedHome" + +getNestedDetailR :: Int -> SubHandlerFor SplitSub master Text +getNestedDetailR n = pure ("nestedDetail:" <> tshow n) + where + tshow = pack . show + +$(mkNestedSubDispatchInstance + defaultOpts + "NestedR" + [] -- no instance context + NoTyArgs -- no type arguments (non-parameterized subsite) + return -- handler unwrapper + resourcesSplitSub) diff --git a/test/YesodCoreTest/SplitSubsite/Runtime.hs b/test/YesodCoreTest/SplitSubsite/Runtime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/SplitSubsite/Runtime.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | End-to-end test that a subsite's nested routes can be split across +-- modules. The nested dispatch + handlers live in +-- "YesodCoreTest.SplitSubsite.NestedR"; here we only define the host site, +-- the subsite's top-level 'YesodSubDispatch' instance (which delegates to the +-- separately compiled 'YesodSubDispatchNested' instance), and the leaf +-- handler. We never import the nested handlers — proving the split. +module YesodCoreTest.SplitSubsite.Runtime (splitSubsiteSpec) where + +import Test.Hspec +import Yesod.Core +import Network.Wai (defaultRequest, pathInfo) +import Network.Wai.Test +import Data.Text (Text) +import qualified Data.ByteString.Lazy.Char8 as L8 + +import YesodCoreTest.SplitSubsite.Data +-- Bring the split-out YesodSubDispatchNested instance into scope. We import +-- the instance only — none of the nested handlers leak into this module. +import YesodCoreTest.SplitSubsite.NestedR () + +data App = App { getSplit :: SplitSub } + +mkYesod "App" [parseRoutes| +/split SplitSubR SplitSub getSplit +|] + +instance Yesod App + +getSplitHomeR :: SubHandlerFor SplitSub master Text +getSplitHomeR = pure "splitHome" + +instance YesodSubDispatch SplitSub master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesSplitSub) + +app :: App +app = App { getSplit = SplitSub } + +runner :: Session () -> IO () +runner f = toWaiApp app >>= runSession f + +splitSubsiteSpec :: Spec +splitSubsiteSpec = describe "YesodCoreTest.SplitSubsite.Runtime (split subsite routes)" $ do + it "dispatches the subsite's own leaf route" $ runner $ do + res <- request defaultRequest { pathInfo = ["split"] } + assertStatus 200 res + assertBody (L8.pack "splitHome") res + it "delegates the nested home route to the split-out module" $ runner $ do + res <- request defaultRequest { pathInfo = ["split", "nested"] } + assertStatus 200 res + assertBody (L8.pack "nestedHome") res + it "delegates a nested dynamic route to the split-out module" $ runner $ do + res <- request defaultRequest { pathInfo = ["split", "nested", "detail", "7"] } + assertStatus 200 res + assertBody (L8.pack "nestedDetail:7") res diff --git a/test/YesodCoreTest/SubsiteFallthrough/Data.hs b/test/YesodCoreTest/SubsiteFallthrough/Data.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/SubsiteFallthrough/Data.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Subsite route data for the nested-route fallthrough runtime test. Both +-- subsites have a nested parent @WrapR@ containing two sibling sub-parents that +-- share the @\/foo@ prefix: the first (@FooAR@) matches only an empty suffix +-- (its index), the second (@FooBR@) matches @\/bar@. A request for +-- @\/wrap\/foo\/bar@ therefore misses in @FooAR@ and can only reach @FooBR@ by +-- falling through — the behaviour the dispatch modules toggle. +-- +-- The route data lives here, apart from the 'mkNestedSubDispatchInstance' +-- splices in "YesodCoreTest.SubsiteFallthrough.Nested", because the +-- generated @resources*@ binding can't feed a splice in the same module (GHC +-- stage restriction) — the same split "YesodCoreTest.SplitSubsite.Runtime" uses. +module YesodCoreTest.SubsiteFallthrough.Data where + +import Yesod.Core + +data FallOnSub = FallOnSub + +mkYesodSubData "FallOnSub" [parseRoutes| +/wrap OnWrapR: + /foo OnFooAR: + / OnFooAIndexR GET + /foo OnFooBR: + /bar OnFooBBarR GET +|] + +data FallOffSub = FallOffSub + +mkYesodSubData "FallOffSub" [parseRoutes| +/wrap OffWrapR: + /foo OffFooAR: + / OffFooAIndexR GET + /foo OffFooBR: + /bar OffFooBBarR GET +|] diff --git a/test/YesodCoreTest/SubsiteFallthrough/Nested.hs b/test/YesodCoreTest/SubsiteFallthrough/Nested.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/SubsiteFallthrough/Nested.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | The split-out dispatch module for the fallthrough subsites' nested +-- @WrapR@ fragments. The nested handlers live here, alongside the +-- 'YesodSubDispatchNested' instances generated by 'mkNestedSubDispatchInstance' +-- — @FallOnSub@ with fallthrough enabled, @FallOffSub@ at the default. +-- +-- Compiled separately from "YesodCoreTest.SubsiteFallthrough.Runtime" so the host +-- site's 'mkYesodSubDispatch' splice sees these instances via 'isInstance' and +-- delegates @WrapR@ to them; the delegated 'YesodSubDispatchNested' is what +-- routes through 'genNestedDispatchClauses' and so honours the fallthrough +-- flag baked in here. +module YesodCoreTest.SubsiteFallthrough.Nested () where + +import Yesod.Core +import Yesod.Core.Dispatch + (mkNestedSubDispatchInstance, TyArgs(..)) +import Data.Text (Text) + +import YesodCoreTest.SubsiteFallthrough.Data + +-- Fallthrough ENABLED subsite ---------------------------------------------- + +getOnFooAIndexR :: SubHandlerFor FallOnSub master Text +getOnFooAIndexR = pure "onFooAIndex" + +getOnFooBBarR :: SubHandlerFor FallOnSub master Text +getOnFooBBarR = pure "onFooBBar" + +$(mkNestedSubDispatchInstance + (setNestedRouteFallthrough True defaultOpts) + "OnWrapR" + [] + NoTyArgs + return + resourcesFallOnSub) + +-- Fallthrough DISABLED subsite (default opts) ------------------------------ + +getOffFooAIndexR :: SubHandlerFor FallOffSub master Text +getOffFooAIndexR = pure "offFooAIndex" + +getOffFooBBarR :: SubHandlerFor FallOffSub master Text +getOffFooBBarR = pure "offFooBBar" + +$(mkNestedSubDispatchInstance + defaultOpts + "OffWrapR" + [] + NoTyArgs + return + resourcesFallOffSub) diff --git a/test/YesodCoreTest/SubsiteFallthrough/Runtime.hs b/test/YesodCoreTest/SubsiteFallthrough/Runtime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/SubsiteFallthrough/Runtime.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Runtime (WAI) coverage for subsite nested-route fallthrough. Every other +-- 'setNestedRouteFallthrough' fixture is a top-level site; this mounts two +-- subsites — one with fallthrough enabled, one without — and proves that a +-- request which misses inside a nested parent reaches the sibling route only +-- when the subsite was generated with fallthrough on. See +-- "YesodCoreTest.SubsiteFallthrough.Data" for the subsite definitions. +module YesodCoreTest.SubsiteFallthrough.Runtime (specs) where + +import Test.Hspec +import Yesod.Core + +import YesodCoreTest.SubsiteFallthrough.Data +-- Bring the split-out YesodSubDispatchNested instances into scope (instances +-- only) so the host site's mkYesodSubDispatch delegates WrapR to them. +import YesodCoreTest.SubsiteFallthrough.Nested () +import YesodCoreTest.RuntimeHarness (assertGet) + +data FallApp = FallApp + +getOnSub :: FallApp -> FallOnSub +getOnSub _ = FallOnSub + +getOffSub :: FallApp -> FallOffSub +getOffSub _ = FallOffSub + +mkYesod "FallApp" [parseRoutes| +/on OnSubR FallOnSub getOnSub +/off OffSubR FallOffSub getOffSub +|] + +instance Yesod FallApp + +-- The host site delegates each subsite's nested @WrapR@ to the +-- 'YesodSubDispatchNested' instance imported from +-- "YesodCoreTest.SubsiteFallthrough.Data". +instance YesodSubDispatch FallOnSub master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesFallOnSub) + +instance YesodSubDispatch FallOffSub master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesFallOffSub) + +specs :: Spec +specs = describe "YesodCoreTest.SubsiteFallthrough.Runtime (subsite nested-route fallthrough)" $ do + describe "fallthrough enabled" $ do + it "still reaches the shadowing nested index route" $ + assertGet FallApp 200 ["on", "wrap", "foo"] (Just "onFooAIndex") + it "falls through a nested miss to the sibling route" $ + assertGet FallApp 200 ["on", "wrap", "foo", "bar"] (Just "onFooBBar") + + describe "fallthrough disabled (default)" $ do + it "still reaches the shadowing nested index route" $ + assertGet FallApp 200 ["off", "wrap", "foo"] (Just "offFooAIndex") + it "404s after a nested miss instead of falling through to the sibling" $ + assertGet FallApp 404 ["off", "wrap", "foo", "bar"] Nothing diff --git a/test/YesodCoreTest/SubsiteOptsFallthrough/Data.hs b/test/YesodCoreTest/SubsiteOptsFallthrough/Data.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/SubsiteOptsFallthrough/Data.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Subsite route data for the 'mkYesodSubDispatchInstanceOpts' fallthrough +-- runtime test. Unlike "YesodCoreTest.SubsiteFallthrough.Data" (whose sibling +-- parents live one level down inside @WrapR@), these subsites place two +-- same-prefix parents at the subsite's *own top level* — the exact seam that +-- the @yesodSubDispatch@ body's inline parent clauses govern. @FirstFooR@ +-- matches only an empty suffix (its index); @SecondFooR@ matches @\/bar@. A +-- request for @\/foo\/bar@ misses inside @FirstFooR@ and can only reach +-- @SecondFooR@ by falling through — the behaviour that +-- 'mkYesodSubDispatchInstanceOpts' must now thread into the body via +-- 'setNestedRouteFallthrough'. +-- +-- The route data lives apart from the dispatch splice (which goes in the test +-- module) because the generated @resources*@ binding can't feed a splice in +-- the same module (GHC stage restriction). +module YesodCoreTest.SubsiteOptsFallthrough.Data where + +import Yesod.Core + +data OptsOnSub = OptsOnSub + +mkYesodSubData "OptsOnSub" [parseRoutes| +/foo OnFirstFooR: + / OnFooIndexR GET +/foo OnSecondFooR: + /bar OnFooBarR GET +|] + +data OptsOffSub = OptsOffSub + +mkYesodSubData "OptsOffSub" [parseRoutes| +/foo OffFirstFooR: + / OffFooIndexR GET +/foo OffSecondFooR: + /bar OffFooBarR GET +|] diff --git a/test/YesodCoreTest/SubsiteOptsFallthrough/Runtime.hs b/test/YesodCoreTest/SubsiteOptsFallthrough/Runtime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/SubsiteOptsFallthrough/Runtime.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Runtime (WAI) coverage for 'mkYesodSubDispatchInstanceOpts' with +-- 'setNestedRouteFallthrough'. The headline use case of that entry point — +-- a subsite whose own top-level parent clauses fall through to a later sibling +-- on an inner miss — was previously a no-op: the generated @yesodSubDispatch@ +-- body came from the opts-less 'mkYesodSubDispatch', which hardcoded +-- @mdsNestedRouteFallthrough = False@. This pins the fix. +-- +-- Two subsites are mounted: 'OptsOnSub' generated with fallthrough on, +-- 'OptsOffSub' at the default. Both have two same-prefix top-level parents +-- (@\/foo FirstFooR@ then @\/foo SecondFooR@); @\/foo\/bar@ reaches the +-- @SecondFooR@ sibling only when the body honours the flag. See +-- "YesodCoreTest.SubsiteOptsFallthrough.Data" for the route data. +module YesodCoreTest.SubsiteOptsFallthrough.Runtime (specs) where + +import Data.Text (Text) +import Test.Hspec +import Yesod.Core +import Yesod.Core.Dispatch (mkYesodSubDispatchInstanceOpts) + +import YesodCoreTest.SubsiteOptsFallthrough.Data +import YesodCoreTest.RuntimeHarness (assertGet) + +-- Handlers for the fallthrough-ENABLED subsite. +getOnFooIndexR :: SubHandlerFor OptsOnSub master Text +getOnFooIndexR = pure "onFooIndex" + +getOnFooBarR :: SubHandlerFor OptsOnSub master Text +getOnFooBarR = pure "onFooBar" + +-- Handlers for the fallthrough-DISABLED subsite. +getOffFooIndexR :: SubHandlerFor OptsOffSub master Text +getOffFooIndexR = pure "offFooIndex" + +getOffFooBarR :: SubHandlerFor OptsOffSub master Text +getOffFooBarR = pure "offFooBar" + +-- The API under test: the @yesodSubDispatch@ body must thread the fallthrough +-- flag from these opts so the subsite's own top-level @FirstFooR@/@SecondFooR@ +-- siblings fall through. Placed before 'mkYesod' so the host dispatch sees the +-- generated subsite instances. +mkYesodSubDispatchInstanceOpts + (setNestedRouteFallthrough True defaultOpts) + "OptsOnSub" + resourcesOptsOnSub + +mkYesodSubDispatchInstanceOpts + defaultOpts + "OptsOffSub" + resourcesOptsOffSub + +data OptsFallApp = OptsFallApp + +getOnSub :: OptsFallApp -> OptsOnSub +getOnSub _ = OptsOnSub + +getOffSub :: OptsFallApp -> OptsOffSub +getOffSub _ = OptsOffSub + +mkYesod "OptsFallApp" [parseRoutes| +/on OnSubR OptsOnSub getOnSub +/off OffSubR OptsOffSub getOffSub +|] + +instance Yesod OptsFallApp + +specs :: Spec +specs = describe "YesodCoreTest.SubsiteOptsFallthrough.Runtime (mkYesodSubDispatchInstanceOpts fallthrough)" $ do + describe "fallthrough enabled (setNestedRouteFallthrough True)" $ do + it "still reaches the shadowing top-level index route" $ + assertGet OptsFallApp 200 ["on", "foo"] (Just "onFooIndex") + it "falls through a top-level parent miss to the sibling route" $ + assertGet OptsFallApp 200 ["on", "foo", "bar"] (Just "onFooBar") + + describe "fallthrough disabled (default)" $ do + it "still reaches the shadowing top-level index route" $ + assertGet OptsFallApp 200 ["off", "foo"] (Just "offFooIndex") + it "404s after a top-level parent miss instead of falling through" $ + assertGet OptsFallApp 404 ["off", "foo", "bar"] Nothing diff --git a/test/YesodCoreTest/WaiSubsite.hs b/test/YesodCoreTest/WaiSubsite.hs --- a/test/YesodCoreTest/WaiSubsite.hs +++ b/test/YesodCoreTest/WaiSubsite.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} diff --git a/test/YesodCoreTest/ZeroPieceShadow/FallApp.hs b/test/YesodCoreTest/ZeroPieceShadow/FallApp.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ZeroPieceShadow/FallApp.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | The same zero-piece-parent shape as "YesodCoreTest.ZeroPieceShadow.ShadowApp", +-- but built with @'setNestedRouteFallthrough' True@. With fallthrough enabled +-- the @WildP@ parent no longer swallows non-matching paths, so the sibling +-- @\/sibling@ becomes reachable. Pinned by "YesodCoreTest.ZeroPieceShadowRuntime". +module YesodCoreTest.ZeroPieceShadow.FallApp + ( FallApp (..) + ) where + +import Yesod.Core + +data FallApp = FallApp + +mkYesodOpts (setNestedRouteFallthrough True defaultOpts) "FallApp" [parseRoutes| +/ FallParentR: + /child FallChildR GET +/sibling FallSiblingR GET +|] + +instance Yesod FallApp where + messageLoggerSource = mempty + +getFallChildR :: HandlerFor FallApp String +getFallChildR = pure "FallChildR" + +getFallSiblingR :: HandlerFor FallApp String +getFallSiblingR = pure "FallSiblingR" diff --git a/test/YesodCoreTest/ZeroPieceShadow/ShadowApp.hs b/test/YesodCoreTest/ZeroPieceShadow/ShadowApp.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ZeroPieceShadow/ShadowApp.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | A zero-piece nested parent (pattern @\/@) followed by a sibling, built with +-- the default @fallthrough = False@. The parent's match pattern is @WildP@ +-- (unconditional), so @\/sibling@ is shadowed: it is swallowed by the parent +-- and 404s. See "YesodCoreTest.ZeroPieceShadow.FallApp" for the fallthrough +-- counterpart. Pinned by "YesodCoreTest.ZeroPieceShadowRuntime". +module YesodCoreTest.ZeroPieceShadow.ShadowApp + ( ShadowApp (..) + ) where + +import Yesod.Core + +data ShadowApp = ShadowApp + +mkYesodOpts defaultOpts "ShadowApp" [parseRoutes| +/ ShadowParentR: + /child ShadowChildR GET +/sibling SiblingR GET +|] + +instance Yesod ShadowApp where + messageLoggerSource = mempty + +getShadowChildR :: HandlerFor ShadowApp String +getShadowChildR = pure "ShadowChildR" + +getSiblingR :: HandlerFor ShadowApp String +getSiblingR = pure "SiblingR" diff --git a/test/YesodCoreTest/ZeroPieceShadowRuntime.hs b/test/YesodCoreTest/ZeroPieceShadowRuntime.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ZeroPieceShadowRuntime.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Regression coverage for the documented edge case: a nested parent route +-- with /no/ leading path piece (pattern @\/@) compiles to an unconditional +-- first match ('mkPathPat' @EndWild []@ = @WildP@), so any sibling route +-- declared after it is unreachable under the default +-- @'setNestedRouteFallthrough' False@. Enabling fallthrough lets a non-matching +-- subtree fall through to the siblings. +-- +-- This is unchanged behaviour from previous releases (the leaf-level overlap +-- check never flagged it, since the parent contributes zero pieces and the +-- flattened leaf paths @\/child@ vs @\/sibling@ do not overlap). The +-- @EndWild@/@PathTail@ abstraction made the shadow silent, so it is pinned here. +module YesodCoreTest.ZeroPieceShadowRuntime + ( specs + ) where + +import Test.Hspec +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text) +import YesodCoreTest.ZeroPieceShadow.ShadowApp (ShadowApp (..)) +import YesodCoreTest.ZeroPieceShadow.FallApp (FallApp (..)) +import YesodCoreTest.RuntimeHarness (assertGet) + +shadowReq :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO () +shadowReq = assertGet ShadowApp + +fallReq :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO () +fallReq = assertGet FallApp + +specs :: Spec +specs = describe "zero-piece nested parent shadowing siblings" $ do + describe "default fallthrough = False (the parent's WildP shadows the sibling)" $ do + it "still dispatches the parent's own child (/child)" $ + shadowReq 200 ["child"] (Just "ShadowChildR") + it "404s the shadowed sibling (/sibling), which the WildP parent swallows" $ + shadowReq 404 ["sibling"] Nothing + + describe "setNestedRouteFallthrough True (the sibling becomes reachable)" $ do + it "still dispatches the parent's own child (/child)" $ + fallReq 200 ["child"] (Just "FallChildR") + it "falls through the WildP parent to the sibling (/sibling)" $ + fallReq 200 ["sibling"] (Just "FallSiblingR") diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.29.1 +version: 1.7.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -20,6 +20,7 @@ test/fixtures/routes_with_line_continuations.yesodroutes ChangeLog.md README.md + docs/split-route-compilation.md library default-language: Haskell2010 @@ -56,6 +57,8 @@ , shakespeare >= 2.0 , template-haskell >= 2.13 , text >= 0.7 + , th-compat >= 0.1 + , th-lift-instances >= 0.1 , time >= 1.5 , transformers >= 0.4 , unix-compat @@ -78,6 +81,7 @@ Yesod.Core.Types Yesod.Core.Unsafe Yesod.Routes.TH.Types + Yesod.Core.Class.Dispatch.ToParentRoute other-modules: Yesod.Core.Internal.Session Yesod.Core.Internal.Request Yesod.Core.Class.Handler @@ -104,6 +108,7 @@ Yesod.Routes.TH.RenderRoute Yesod.Routes.TH.ParseRoute Yesod.Routes.TH.RouteAttrs + Yesod.Routes.TH.Internal ghc-options: -Wall @@ -117,6 +122,12 @@ hs-source-dirs: test, src other-modules: Hierarchy + Hierarchy.Admin + Hierarchy.ResourceTree + Hierarchy.Nest2.NestInner + Hierarchy.Nest2 + Hierarchy.Nest3 + Hierarchy.Nest Yesod.Routes.Class Yesod.Routes.Overlap Yesod.Routes.Parse @@ -126,21 +137,77 @@ Yesod.Routes.TH.RenderRoute Yesod.Routes.TH.RouteAttrs Yesod.Routes.TH.Types + Yesod.Routes.TH.Internal + Route.FallthroughSpec + YesodCoreTest.RuntimeHarness + Route.RenderRouteSpec + Route.RouteAttrSpec + Route.DiscoveryModeSpec + Route.SubDispatchAritySpec + Route.DeepAritySpec + Route.DeepArityTypes + Route.InstanceProbeSpec + Route.InstanceProbeTypes + Route.InlineParseClausesSpec + Route.NestedParseClausesSpec + Route.PureQ + Route.FocusLeafConsSpec + Route.MissingFocusTargetSpec + Route.MissingFocusTargetTypes + YesodCoreTest.RenderRouteSpec + YesodCoreTest.RenderRouteSpec.TH -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443 other-extensions: TemplateHaskell build-depends: base < 5 - , hspec - , containers + , HUnit + , aeson + , attoparsec-aeson + , auto-update + , blaze-html + , blaze-markup , bytestring + , hspec-expectations + , case-insensitive + , cereal + , clientsession + , conduit + , conduit-extra + , containers + , cookie + , data-default + , deepseq , encoding + , entropy + , fast-logger + , hspec + , http-types + , memory + , monad-logger + , mtl + , parsec + , path-pieces + , primitive + , random + , resourcet + , shakespeare , template-haskell , text - , random - , path-pieces - , HUnit , th-abstraction + , th-compat + , th-lift-instances + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , wai + , wai-extra + , wai-logger + , warp + , word8 test-suite tests default-language: Haskell2010 @@ -159,6 +226,8 @@ YesodCoreTest.ErrorHandling YesodCoreTest.ErrorHandling.CustomApp YesodCoreTest.Exceptions + YesodCoreTest.FallthroughDispatch.Runtime + YesodCoreTest.FallthroughDispatch.Resources YesodCoreTest.InternalRequest YesodCoreTest.JsAttributes YesodCoreTest.JsLoader @@ -169,6 +238,13 @@ YesodCoreTest.Media YesodCoreTest.MediaData YesodCoreTest.Meta + YesodCoreTest.NestedDispatch.Runtime + YesodCoreTest.NestedDispatch.NestR + YesodCoreTest.NestedDispatch.InnerR + YesodCoreTest.NestedDispatch.ParentR + YesodCoreTest.NestedDispatch.Parent0R + YesodCoreTest.NestedDispatch.Parent0R.Child0R + YesodCoreTest.NestedDispatch.Resources YesodCoreTest.NoOverloadedStrings YesodCoreTest.NoOverloadedStringsSub YesodCoreTest.ParameterizedSite @@ -188,6 +264,42 @@ YesodCoreTest.StubUnsecured YesodCoreTest.SubSub YesodCoreTest.SubSubData + YesodCoreTest.SplitSubsite.Runtime + YesodCoreTest.SplitSubsite.Data + YesodCoreTest.SplitSubsite.NestedR + YesodCoreTest.ParameterizedSubData + YesodCoreTest.ParamSubsite.Data + YesodCoreTest.ParameterizedSubDispatch + YesodCoreTest.ParameterizedSubDispatch.Data + YesodCoreTest.ParameterizedSubDispatchRuntime + YesodCoreTest.ParameterizedSubDispatchRuntime.Data + YesodCoreTest.ParamSubsite.InstanceRuntime + YesodCoreTest.RuntimeHarness + YesodCoreTest.ParamSubsite.SplitNested + YesodCoreTest.ParamSubsite.SplitRuntime + YesodCoreTest.ParamDefaultSplit.Data + YesodCoreTest.ParamDefaultSplit.Runtime + YesodCoreTest.ParamTopLevelRuntime + YesodCoreTest.ParamFocusSplit.Runtime + YesodCoreTest.ParamFocusSplit.Resources + YesodCoreTest.ParamFocusSplit.SubR + YesodCoreTest.ParamNoExplicitArgs + YesodCoreTest.ParamFallthroughRuntime + YesodCoreTest.ParamNoFallthroughRuntime + YesodCoreTest.ParamNestedNoFallthroughRuntime + YesodCoreTest.FallthroughMatrix.Resources + YesodCoreTest.FallthroughMatrix.FirstFoo + YesodCoreTest.FallthroughMatrix.Runtime + YesodCoreTest.MultiPieceNestedRuntime + YesodCoreTest.ZeroPieceShadowRuntime + YesodCoreTest.ZeroPieceShadow.ShadowApp + YesodCoreTest.ZeroPieceShadow.FallApp + YesodCoreTest.BangSeparatorRuntime + YesodCoreTest.SubsiteFallthrough.Runtime + YesodCoreTest.SubsiteFallthrough.Data + YesodCoreTest.SubsiteFallthrough.Nested + YesodCoreTest.SubsiteOptsFallthrough.Runtime + YesodCoreTest.SubsiteOptsFallthrough.Data YesodCoreTest.WaiSubsite YesodCoreTest.Widget YesodCoreTest.YesodTest @@ -203,6 +315,7 @@ , conduit-extra , containers , cookie >= 0.4.1 && < 0.6 + , data-default , encoding , hspec >= 1.3 , hspec-expectations @@ -212,13 +325,44 @@ , resourcet , shakespeare , streaming-commons + , template-haskell , text , transformers , unliftio + , unordered-containers + , path-pieces + , mtl + , time + , cereal + , monad-logger + , deepseq + , blaze-html + , aeson + , primitive + , case-insensitive + , wai-logger + , memory + , unix-compat + , auto-update + , vector + , word8 + , blaze-markup + , fast-logger + , parsec , wai >= 3.0 + , entropy + , attoparsec-aeson , wai-extra , warp + , th-lift-instances , yesod-core + -- NB: this behavioral suite depends on the *packaged* yesod-core library + -- (no `src` on hs-source-dirs), so it compiles against the real + -- exposed/hidden module boundary. That is what catches API-exposure + -- regressions (a module that downstream consumers cannot import). The + -- pure-codegen suite `test-routes` keeps `src` on hs-source-dirs because it + -- legitimately needs internal modules (e.g. Yesod.Routes.TH.RenderRoute, + -- Yesod.Routes.Class) for compile-time codegen assertions. ghc-options: -Wall -threaded other-extensions: TemplateHaskell