diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,192 @@ # 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) + +## 1.6.29.0 + +* When showing HandlerContent, include a content snippet [#1864](https://github.com/yesodweb/yesod/pull/1864) + +## 1.6.28.1 + +* Add type arguments to the sub routes [#1866](https://github.com/yesodweb/yesod/pull/1866) + +## 1.6.28.0 + +* Allow users to control generation of the `resourcesSite :: [ResourceTree String]` value. [#1881](https://github.com/yesodweb/yesod/pull/1881) + +## 1.6.27.1 + +* Set `base >= 4.11` for less CPP and imports [#1876](https://github.com/yesodweb/yesod/pull/1876) + +## 1.6.27.0 + +* Build with `wai-extra-3.1.17` [#1861](https://github.com/yesodweb/yesod/pull/1861) + +## 1.6.26.0 + +* Always apply jsAttributes to julius script blocks of body [#1836](https://github.com/yesodweb/yesod/pull/1836) + +## 1.6.25.1 + +* Export the options that were created in 1.6.25.0 [#1825](https://github.com/yesodweb/yesod/pull/1825) + +## 1.6.25.0 + +* Add an options structure that allows the user to set which instances will be derived for a routes structure. [#1819](https://github.com/yesodweb/yesod/pull/1819) + +## 1.6.24.5 + +* Support Aeson 2.2 [#1818](https://github.com/yesodweb/yesod/pull/1818) + +## 1.6.24.4 + +* Fix test-suite compilation error for GHC >= 9.0.1 [#1812](https://github.com/yesodweb/yesod/pull/1812) + +## 1.6.24.3 + +* Fix subsite-to-subsite dispatch [#1805](https://github.com/yesodweb/yesod/pull/1805) + +## 1.6.24.2 + +* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797) + +## 1.6.24.1 + +* Adapt to removal of `ListT` from transformers-0.6. [#1796](https://github.com/yesodweb/yesod/pull/1796) + +## 1.6.24.0 + +* Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772). + +## 1.6.23.1 + +* Fix typo in creation of the description `` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766) + +## 1.6.23 + +* Add idempotent versions of `setDescription`, `setDescriptionI`. These functions + have odd behaviour when called multiple times, so they are now warned against. + This can't be a silent change - if you want to switch to the new functions, make + sure your layouts are updated to use `pageDescription` as well as `pageTitle`. + [#1765](https://github.com/yesodweb/yesod/pull/1765) + +## 1.6.22.1 + ++ Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756) + +## 1.6.22.0 + +* Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745) +* Add instances for `ToContent Void`, `ToTypedContent Void`. [#1752](https://github.com/yesodweb/yesod/pull/1752) +* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753) +* Support template-haskell 2.18 [#1754](https://github.com/yesodweb/yesod/pull/1754) + +## 1.6.21.0 + +* Export `Yesod.Core.Dispatch.defaultGen` so that users may reuse it for their own `YesodRunnerEnv`s [#1734](https://github.com/yesodweb/yesod/pull/1734) + +## 1.6.20.2 + +* Fix compatibility with template-haskell 2.17 [#1729](https://github.com/yesodweb/yesod/pull/1729) + +## 1.6.20.1 + +* Throw an error in `breadcrumbs` if the trail of breadcrumbs is circular. [#1727](https://github.com/yesodweb/yesod/issues/1727) + +## 1.6.20 + +* Generate CSRF tokens using a secure entropy source [#1726](https://github.com/yesodweb/yesod/pull/1726) +* Change semantics of `yreGen` and `defaultGen` + +## 1.6.19.0 + +* Change order of priority in `languages`[#1721](https://github.com/yesodweb/yesod/pull/1721) + +## 1.6.18.8 + +* Fix test suite for wai-extra change around vary header + +## 1.6.18.7 + +* Fix functions generating Open Graph metadata[#1709](https://github.com/yesodweb/yesod/pull/1709) + +## 1.6.18.6 + +* Update documentation from `HandlerT` to `HandlerFor` [#1703](https://github.com/yesodweb/yesod/pull/1703) + +## 1.6.18.5 + +Document `ErrorResponse` [#1698](https://github.com/yesodweb/yesod/pull/1698) + +## 1.6.18.4 + +* Fixed a bug where `mkYesod` and other TH functions didn't work for datatypes with explicitly stated type variables, including the case with typeclass constraints. [https://github.com/yesodweb/yesod/pull/1697](#1697) + +## 1.6.18.3 + +* Remove mention of an oudated Yesod type (`GHandler`) from the docs for `handlerToIO`. [https://github.com/yesodweb/yesod/pull/1695](#1695) + +## 1.6.18.2 + +* Recommends `.yesodroutes` as the file extension for Yesod routes files. [#1686](https://github.com/yesodweb/yesod/pull/1686) + +## 1.6.18.1 + +* Increase the size of CSRF token + +## 1.6.18 + +* Add functions for setting description and OG meta [#1663](https://github.com/yesodweb/yesod/pull/1663) + +* Use `DeriveLift` to implement the `Lift` instances for `ResourceTree`, + `Resource`, `Piece`, and `Dispatch`. Among other benefits, this provides + implementations of `liftTyped` on `template-haskell-2.16` (GHC 8.10) or + later. [#1664](https://github.com/yesodweb/yesod/pull/1664) + +## 1.6.17.3 + +* Support for `unliftio-core` 0.2 + +## 1.6.17.2 + +* Support template-haskell 2.16, build with GHC 8.10 [#1657](https://github.com/yesodweb/yesod/pull/1657) + +## 1.6.17.1 + +* Remove unnecessary deriving of Typeable + +## 1.6.17 + +* Adds `contentTypeIsJson` [#1646](https://github.com/yesodweb/yesod/pull/1646) + +## 1.6.16.1 + +* Compiles with GHC 8.8.1 + +## 1.6.16 + +* Add `jsAttributesHandler` to run arbitrary Handler code before building the + attributes map for the script tag generated by `widgetFile` [#1622](https://github.com/yesodweb/yesod/pull/1622) + +## 1.6.15 + +* Move `redirectToPost` JavaScript form submission from HTML element to + `" res + +runner :: YesodDispatch master => master -> Session () -> IO () +runner app f = toWaiApp app >>= runSession f diff --git a/test/YesodCoreTest/JsLoader.hs b/test/YesodCoreTest/JsLoader.hs --- a/test/YesodCoreTest/JsLoader.hs +++ b/test/YesodCoreTest/JsLoader.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module YesodCoreTest.JsLoader ( specs , Widget diff --git a/test/YesodCoreTest/JsLoaderSites/Bottom.hs b/test/YesodCoreTest/JsLoaderSites/Bottom.hs --- a/test/YesodCoreTest/JsLoaderSites/Bottom.hs +++ b/test/YesodCoreTest/JsLoaderSites/Bottom.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module YesodCoreTest.JsLoaderSites.Bottom ( B(..) , Widget diff --git a/test/YesodCoreTest/Json.hs b/test/YesodCoreTest/Json.hs --- a/test/YesodCoreTest/Json.hs +++ b/test/YesodCoreTest/Json.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + module YesodCoreTest.Json ( specs , Widget diff --git a/test/YesodCoreTest/Links.hs b/test/YesodCoreTest/Links.hs --- a/test/YesodCoreTest/Links.hs +++ b/test/YesodCoreTest/Links.hs @@ -1,6 +1,11 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + module YesodCoreTest.Links ( linksTest , Widget diff --git a/test/YesodCoreTest/LiteApp.hs b/test/YesodCoreTest/LiteApp.hs --- a/test/YesodCoreTest/LiteApp.hs +++ b/test/YesodCoreTest/LiteApp.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module YesodCoreTest.LiteApp (specs) where import Yesod.Core diff --git a/test/YesodCoreTest/Media.hs b/test/YesodCoreTest/Media.hs --- a/test/YesodCoreTest/Media.hs +++ b/test/YesodCoreTest/Media.hs @@ -1,7 +1,12 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module YesodCoreTest.Media (mediaTest, Widget) where import Test.Hspec diff --git a/test/YesodCoreTest/MediaData.hs b/test/YesodCoreTest/MediaData.hs --- a/test/YesodCoreTest/MediaData.hs +++ b/test/YesodCoreTest/MediaData.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module YesodCoreTest.MediaData where import Yesod.Core diff --git a/test/YesodCoreTest/Meta.hs b/test/YesodCoreTest/Meta.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/Meta.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module YesodCoreTest.Meta + ( metaTest + ) where + +import Test.Hspec + +import Yesod.Core +import Network.Wai +import Network.Wai.Test + +data App = App + +mkYesod "App" [parseRoutes| +/title TitleR GET +/desc DescriptionR GET +|] + +instance Yesod App where + +getTitleR :: Handler Html +getTitleR = defaultLayout $ do + setTitle "First title" + setTitle "Second title" + +getDescriptionR :: Handler Html +getDescriptionR = defaultLayout $ do + setDescriptionIdemp "First description" + setDescriptionIdemp "Second description" + +metaTest :: Spec +metaTest = describe "Setting page metadata" $ do + describe "Yesod.Core.Widget.setTitle" $ do + it "is idempotent" $ runner $ do + res <- request defaultRequest + { pathInfo = ["title"] + } + assertBody "\nSecond title" res + describe "Yesod.Core.Widget.setDescriptionIdemp" $ do + it "is idempotent" $ runner $ do + res <- request defaultRequest + { pathInfo = ["desc"] + } + assertBody "\n" res + +runner :: Session () -> IO () +runner f = toWaiAppPlain App >>= runSession f 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/NoOverloadedStrings.hs b/test/YesodCoreTest/NoOverloadedStrings.hs --- a/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/test/YesodCoreTest/NoOverloadedStrings.hs @@ -1,7 +1,13 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!! +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} + module YesodCoreTest.NoOverloadedStrings ( noOverloadedTest , Widget @@ -14,7 +20,6 @@ import Yesod.Core import Network.Wai import Network.Wai.Test -import Data.Monoid (mempty) import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as L8 @@ -65,7 +70,7 @@ case_sanity :: IO () case_sanity = runner $ do res <- request defaultRequest - assertBody Data.Monoid.mempty res + assertBody mempty res case_subsite :: IO () case_subsite = runner $ do diff --git a/test/YesodCoreTest/NoOverloadedStringsSub.hs b/test/YesodCoreTest/NoOverloadedStringsSub.hs --- a/test/YesodCoreTest/NoOverloadedStringsSub.hs +++ b/test/YesodCoreTest/NoOverloadedStringsSub.hs @@ -1,8 +1,12 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} -- hah, the test should be renamed... +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -- hah, the test should be renamed... + -- Not actually a problem, we're now requiring overloaded strings, we just need -- to make the docs more explicit about it. module YesodCoreTest.NoOverloadedStringsSub where 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.hs b/test/YesodCoreTest/ParameterizedSite.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParameterizedSite.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module YesodCoreTest.ParameterizedSite + ( parameterizedSiteTest + ) where + +import Data.ByteString.Lazy (ByteString) +import Network.Wai.Test (runSession, request, defaultRequest, assertBodyContains, setPath) +import Test.Hspec (Spec, describe, it) +import Yesod.Core (YesodDispatch, renderRoute, Route) +import Yesod.Core.Dispatch (toWaiApp) +import Data.Traversable +import Data.Foldable +import Data.Text.Encoding +import Data.Text as T + +import YesodCoreTest.ParameterizedSite.PolyAny (PolyAny (..)) +import YesodCoreTest.ParameterizedSite.PolyShow (PolyShow (..)) +import YesodCoreTest.ParameterizedSite.Compat (Compat (..)) +import qualified YesodCoreTest.ParameterizedSite.SubRoute as SR + +-- These are actually tests for template haskell. So if it compiles, it works +parameterizedSiteTest :: Spec +parameterizedSiteTest = describe "Polymorphic Yesod sites" $ do + it "Polymorphic unconstrained stub" $ runStub (PolyAny ()) + it "Polymorphic stub with Show" $ runStub' "1337" (PolyShow (1337 :: Int)) + it "Polymorphic unconstrained stub, old-style" $ runStub (Compat () ()) + it "Polymorphic stub, sub routes" $ runStubAgainst [(SR.HomeR 456, ["Stub", "123", "456"]), (SR.EditorR (SR.AwayR 789), ["Stub", "123", "789"])] (SR.SubRoute (123 :: Int)) + +runStub :: YesodDispatch a => a -> IO () +runStub stub = + let actions = do + res <- request defaultRequest + assertBodyContains "Stub" res + in toWaiApp stub >>= runSession actions + + +runStub' :: YesodDispatch a => ByteString -> a -> IO () +runStub' body stub = + let actions = do + res <- request defaultRequest + assertBodyContains "Stub" res + assertBodyContains body res + in toWaiApp stub >>= runSession actions + +runStubAgainst :: YesodDispatch a => [(Route a, [ByteString])] -> a -> IO () +runStubAgainst urlBodies stub = + let actions = do + for_ urlBodies $ \(url, bodies) -> do + let (nonQuery, _query) = renderRoute url + let render = T.intercalate "/" nonQuery + let req = setPath defaultRequest (encodeUtf8 render) + res <- request req + for bodies (`assertBodyContains` res) + in toWaiApp stub >>= runSession actions diff --git a/test/YesodCoreTest/ParameterizedSite/Compat.hs b/test/YesodCoreTest/ParameterizedSite/Compat.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParameterizedSite/Compat.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module YesodCoreTest.ParameterizedSite.Compat + ( Compat (..) + ) where + +import Yesod.Core + +-- | Parameterized without constraints, and we call mkYesod without type vars, +-- like people used to do before the last 3 commits +data Compat a b = Compat a b + +mkYesod "Compat" [parseRoutes| +/ HomeR GET +|] + +instance Yesod (Compat a b) + +getHomeR :: Handler a b Html +getHomeR = defaultLayout + [whamlet| +

+ Stub + |] diff --git a/test/YesodCoreTest/ParameterizedSite/PolyAny.hs b/test/YesodCoreTest/ParameterizedSite/PolyAny.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParameterizedSite/PolyAny.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module YesodCoreTest.ParameterizedSite.PolyAny + ( PolyAny (..) + ) where + +import Yesod.Core + +-- | Parameterized without constraints +data PolyAny a = PolyAny a + +mkYesod "PolyAny a" [parseRoutes| +/ HomeR GET +|] + +instance Yesod (PolyAny a) + +getHomeR :: Handler a Html +getHomeR = defaultLayout + [whamlet| +

+ Stub + |] diff --git a/test/YesodCoreTest/ParameterizedSite/PolyShow.hs b/test/YesodCoreTest/ParameterizedSite/PolyShow.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParameterizedSite/PolyShow.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module YesodCoreTest.ParameterizedSite.PolyShow + ( PolyShow (..) + ) where + +import Yesod.Core + +-- | Parameterized with 'Show' constraint +data PolyShow a = PolyShow a + +mkYesod "(Show a) => PolyShow a" [parseRoutes| +/ HomeR GET +|] + +instance Show a => Yesod (PolyShow a) + +getHomeR :: Show a => Handler a Html +getHomeR = do + PolyShow x <- getYesod + defaultLayout + [whamlet| +

+ Stub #{show x} + |] diff --git a/test/YesodCoreTest/ParameterizedSite/SubRoute.hs b/test/YesodCoreTest/ParameterizedSite/SubRoute.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/ParameterizedSite/SubRoute.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE + TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses + , OverloadedStrings, StandaloneDeriving, FlexibleInstances, FlexibleContexts + , ViewPatterns, UndecidableInstances, ConstraintKinds + #-} + + +module YesodCoreTest.ParameterizedSite.SubRoute where + +import Yesod.Core +import Data.Kind (Type) + +type Constraints p = (Eq (Key p), Show (Key p), Read (Key p), PathPiece (Key p), Show p) + +class Constraints p => SiteClass p where + type Key p :: Type + +newtype SubRoute a v = SubRoute a + deriving (Eq, Show, Read) + +instance SiteClass Int where + type Key Int = Int + +mkYesodOpts (setParameterizedSubroute True defaultOpts) "(SiteClass p) => SubRoute p v" [parseRoutes| +/home/#{Key p} HomeR GET +/editor EditorR: + /away/#{Key p} AwayR GET +|] + +{- +The above generates data structures and instances like the following: + + data Route (SubRoute p v) = HomeR (Key p) | EditorR (EditorR p v) + +deriving instance SiteClass p => Eq (Route (SubRoute p v)) +deriving instance SiteClass p => Show (Route (SubRoute p v)) +deriving instance SiteClass p => Read (Route (SubRoute p v)) +data EditorR p v = AwayR (Key p) +deriving instance SiteClass p => Eq (EditorR p v) +deriving instance SiteClass p => Show (EditorR p v) +deriving instance SiteClass p => Read (EditorR p v) + +Note that `p` is now threaded through the other data structures. + +Otherwise, EditorR's definition would've been: +data EditorR + = AwayR (Key p) + 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) + +getHomeR :: SiteClass a => Key a -> HandlerFor (SubRoute a v) Html +getHomeR key = do + SubRoute x <- liftHandler getYesod + defaultLayout + [whamlet| +

+ Stub #{show x} #{show key} + |] + +getAwayR :: SiteClass a => Key a -> HandlerFor (SubRoute a v) Html +getAwayR key1 = do + SubRoute x <- liftHandler getYesod + defaultLayout + [whamlet| +

+ Stub #{show x} #{show key1} + |] 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/RawResponse.hs b/test/YesodCoreTest/RawResponse.hs --- a/test/YesodCoreTest/RawResponse.hs +++ b/test/YesodCoreTest/RawResponse.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module YesodCoreTest.RawResponse ( specs , Widget diff --git a/test/YesodCoreTest/Redirect.hs b/test/YesodCoreTest/Redirect.hs --- a/test/YesodCoreTest/Redirect.hs +++ b/test/YesodCoreTest/Redirect.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module YesodCoreTest.Redirect ( specs , Widget 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/Reps.hs b/test/YesodCoreTest/Reps.hs --- a/test/YesodCoreTest/Reps.hs +++ b/test/YesodCoreTest/Reps.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + module YesodCoreTest.Reps ( specs , Widget diff --git a/test/YesodCoreTest/RequestBodySize.hs b/test/YesodCoreTest/RequestBodySize.hs --- a/test/YesodCoreTest/RequestBodySize.hs +++ b/test/YesodCoreTest/RequestBodySize.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module YesodCoreTest.RequestBodySize ( specs , Widget 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/Ssl.hs b/test/YesodCoreTest/Ssl.hs --- a/test/YesodCoreTest/Ssl.hs +++ b/test/YesodCoreTest/Ssl.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module YesodCoreTest.Ssl ( sslOnlySpec, unsecSpec, sameSiteSpec ) where import qualified YesodCoreTest.StubSslOnly as Ssl import qualified YesodCoreTest.StubLaxSameSite as LaxSameSite @@ -43,7 +48,7 @@ cookiesIn r = DL.map (Cookie.parseSetCookie . snd) - (DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders r) + (DL.filter (("Set-Cookie" ==) . fst) $ simpleHeaders r) sslOnlySpec :: Spec sslOnlySpec = describe "A Yesod application with sslOnly on" $ do diff --git a/test/YesodCoreTest/Streaming.hs b/test/YesodCoreTest/Streaming.hs --- a/test/YesodCoreTest/Streaming.hs +++ b/test/YesodCoreTest/Streaming.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} + module YesodCoreTest.Streaming (specs) where import Yesod.Core diff --git a/test/YesodCoreTest/StubLaxSameSite.hs b/test/YesodCoreTest/StubLaxSameSite.hs --- a/test/YesodCoreTest/StubLaxSameSite.hs +++ b/test/YesodCoreTest/StubLaxSameSite.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module YesodCoreTest.StubLaxSameSite ( App ( App ) , Widget diff --git a/test/YesodCoreTest/StubSslOnly.hs b/test/YesodCoreTest/StubSslOnly.hs --- a/test/YesodCoreTest/StubSslOnly.hs +++ b/test/YesodCoreTest/StubSslOnly.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module YesodCoreTest.StubSslOnly ( App ( App ) , Widget diff --git a/test/YesodCoreTest/StubStrictSameSite.hs b/test/YesodCoreTest/StubStrictSameSite.hs --- a/test/YesodCoreTest/StubStrictSameSite.hs +++ b/test/YesodCoreTest/StubStrictSameSite.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module YesodCoreTest.StubStrictSameSite ( App ( App ) , Widget diff --git a/test/YesodCoreTest/StubUnsecured.hs b/test/YesodCoreTest/StubUnsecured.hs --- a/test/YesodCoreTest/StubUnsecured.hs +++ b/test/YesodCoreTest/StubUnsecured.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module YesodCoreTest.StubUnsecured ( App ( App ) , Widget diff --git a/test/YesodCoreTest/SubSub.hs b/test/YesodCoreTest/SubSub.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/SubSub.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module YesodCoreTest.SubSub where + +import Test.Hspec + +import Yesod.Core +import Network.Wai.Test +import qualified Data.Text as T +import qualified Data.ByteString.Lazy.Char8 as L8 + +import YesodCoreTest.SubSubData + +data App = App { getOuter :: OuterSubSite } + +mkYesod "App" [parseRoutes| +/ OuterSubSiteR OuterSubSite getOuter +|] + +instance Yesod App + +getSubR :: SubHandlerFor InnerSubSite master T.Text +getSubR = return $ T.pack "sub" + +instance YesodSubDispatch OuterSubSite master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesOuterSubSite) + +instance YesodSubDispatch InnerSubSite master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesInnerSubSite) + +app :: App +app = App { getOuter = OuterSubSite { getInner = InnerSubSite }} + +runner :: Session () -> IO () +runner f = toWaiApp app >>= runSession f + +case_subSubsite :: IO () +case_subSubsite = runner $ do + res <- request defaultRequest + assertBody (L8.pack "sub") res + assertStatus 200 res + +subSubTest :: Spec +subSubTest = describe "YesodCoreTest.SubSub" $ do + it "sub_subsite" case_subSubsite diff --git a/test/YesodCoreTest/SubSubData.hs b/test/YesodCoreTest/SubSubData.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/SubSubData.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module YesodCoreTest.SubSubData where + +import Yesod.Core + + +data OuterSubSite = OuterSubSite { getInner :: InnerSubSite } + +data InnerSubSite = InnerSubSite + +mkYesodSubData "InnerSubSite" [parseRoutes| +/ SubR GET +|] + +mkYesodSubData "OuterSubSite" [parseRoutes| +/ InnerSubSiteR InnerSubSite getInner +|] 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,11 @@ -{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings, ViewPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + module YesodCoreTest.WaiSubsite ( specs , Widget diff --git a/test/YesodCoreTest/Widget.hs b/test/YesodCoreTest/Widget.hs --- a/test/YesodCoreTest/Widget.hs +++ b/test/YesodCoreTest/Widget.hs @@ -1,6 +1,11 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + module YesodCoreTest.Widget ( widgetTest , resourcesY @@ -98,7 +103,7 @@ assertBody "\n\n

toWidget

\n

toBody

\n" res runner :: Session () -> IO () -runner f = toWaiApp Y >>= runSession f +runner f = toWaiAppPlain Y >>= runSession f case_addJuliusBody :: IO () case_addJuliusBody = runner $ do 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/test/fixtures/routes_with_line_continuations b/test/fixtures/routes_with_line_continuations deleted file mode 100644 --- a/test/fixtures/routes_with_line_continuations +++ /dev/null @@ -1,11 +0,0 @@ --- This fixture to test line continuations is in a separate file --- because when I put it in an in-line quasi-quotation, the compiler --- performed the line continuations processing itself. - -/foo1 \ - Foo1 -/foo2 Foo2 -/foo3 \ - Foo3 \ - GET POST \ - !foo diff --git a/test/fixtures/routes_with_line_continuations.yesodroutes b/test/fixtures/routes_with_line_continuations.yesodroutes new file mode 100644 --- /dev/null +++ b/test/fixtures/routes_with_line_continuations.yesodroutes @@ -0,0 +1,11 @@ +-- This fixture to test line continuations is in a separate file +-- because when I put it in an in-line quasi-quotation, the compiler +-- performed the line continuations processing itself. + +/foo1 \ + Foo1 +/foo2 Foo2 +/foo3 \ + Foo3 \ + GET POST \ + !foo 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.14 +version: 1.7.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -8,7 +8,7 @@ description: API docs and the README are available at category: Web, Yesod stability: Stable -cabal-version: >= 1.8 +cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/ extra-source-files: @@ -17,15 +17,18 @@ test/YesodCoreTest/JsLoaderSites/Bottom.hs test/en.msg test/test.hs - test/fixtures/routes_with_line_continuations + test/fixtures/routes_with_line_continuations.yesodroutes ChangeLog.md README.md + docs/split-route-compilation.md library + default-language: Haskell2010 hs-source-dirs: src - build-depends: base >= 4.9 && < 5 + build-depends: base >= 4.11 && < 5 , aeson >= 1.0 + , attoparsec-aeson >= 2.1 , auto-update , blaze-html >= 0.5 , blaze-markup >= 0.7.1 @@ -36,8 +39,11 @@ , conduit >= 1.3 , conduit-extra , containers >= 0.2 - , cookie >= 0.4.3 && < 0.5 + , cookie >= 0.4.3 && < 0.6 + , data-default , deepseq >= 1.3 + , encoding + , entropy , fast-logger >= 2.2 , http-types >= 0.7 , memory @@ -46,18 +52,19 @@ , parsec >= 2 && < 3.2 , path-pieces >= 0.1.2 && < 0.3 , primitive >= 0.6 - , random >= 1.0.0.2 && < 1.2 + , random >= 1.0.0.2 && < 1.4 , resourcet >= 1.2 - , rio , shakespeare >= 2.0 - , template-haskell >= 2.11 + , template-haskell >= 2.13 , text >= 0.7 + , th-compat >= 0.1 + , th-lift-instances >= 0.1 , time >= 1.5 , transformers >= 0.4 , unix-compat , unliftio , unordered-containers >= 0.2 - , vector >= 0.9 && < 0.13 + , vector >= 0.9 && < 0.14 , wai >= 3.2 , wai-extra >= 3.0.7 , wai-logger >= 0.2 @@ -74,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 @@ -86,6 +94,10 @@ Yesod.Core.Class.Dispatch Yesod.Core.Class.Breadcrumbs Yesod.Core.TypeCache + Yesod.Core.Types.Content + Yesod.Core.Types.ErrorResponse + Yesod.Core.Types.HandlerContents + Yesod.Core.Types.TypedContent Paths_yesod_core Yesod.Routes.TH @@ -96,21 +108,26 @@ Yesod.Routes.TH.RenderRoute Yesod.Routes.TH.ParseRoute Yesod.Routes.TH.RouteAttrs + Yesod.Routes.TH.Internal ghc-options: -Wall - -- Following line added due to: https://github.com/yesodweb/yesod/issues/545 - -- This looks like a GHC bug - extensions: MultiParamTypeClasses -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443 - extensions: TemplateHaskell + other-extensions: TemplateHaskell test-suite test-routes + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: RouteSpec.hs 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 @@ -120,34 +137,99 @@ 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 - extensions: TemplateHaskell + other-extensions: TemplateHaskell - build-depends: base - , hspec - , containers + build-depends: base < 5 + , 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 type: exitcode-stdio-1.0 main-is: test.hs hs-source-dirs: test other-modules: YesodCoreTest YesodCoreTest.Auth + YesodCoreTest.Breadcrumb YesodCoreTest.Cache YesodCoreTest.CleanPath + YesodCoreTest.Content YesodCoreTest.Header YesodCoreTest.Csrf YesodCoreTest.ErrorHandling + YesodCoreTest.ErrorHandling.CustomApp YesodCoreTest.Exceptions + YesodCoreTest.FallthroughDispatch.Runtime + YesodCoreTest.FallthroughDispatch.Resources YesodCoreTest.InternalRequest + YesodCoreTest.JsAttributes YesodCoreTest.JsLoader YesodCoreTest.JsLoaderSites.Bottom YesodCoreTest.Json @@ -155,8 +237,21 @@ YesodCoreTest.LiteApp 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 + YesodCoreTest.ParameterizedSite.Compat + YesodCoreTest.ParameterizedSite.PolyAny + YesodCoreTest.ParameterizedSite.PolyShow + YesodCoreTest.ParameterizedSite.SubRoute YesodCoreTest.RawResponse YesodCoreTest.Redirect YesodCoreTest.Reps @@ -167,6 +262,44 @@ YesodCoreTest.StubSslOnly YesodCoreTest.StubStrictSameSite 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 @@ -174,14 +307,16 @@ cpp-options: -DTEST if os(windows) cpp-options: -DWINDOWS - build-depends: base + build-depends: base >= 4.11 && < 5 , async , bytestring , clientsession , conduit , conduit-extra , containers - , cookie >= 0.4.1 && < 0.5 + , cookie >= 0.4.1 && < 0.6 + , data-default + , encoding , hspec >= 1.3 , hspec-expectations , http-types @@ -190,20 +325,52 @@ , 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 - extensions: TemplateHaskell + other-extensions: TemplateHaskell benchmark widgets + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: bench - build-depends: base + build-depends: base < 5 , blaze-html , bytestring , gauge