packages feed

yesod-core 1.1.8.3 → 1.7.0.0

raw patch · 170 files changed

Files

+ ChangeLog.md view
@@ -0,0 +1,503 @@+# 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 `<meta>` 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+  `<script>` tag for CSP reasons [#1620](https://github.com/yesodweb/yesod/pull/1620)++## 1.6.14++* Introduce `JSONResponse`. [issue #1481](https://github.com/yesodweb/yesod/issues/1481) and [PR #1592](https://github.com/yesodweb/yesod/pull/1592)++## 1.6.13++* Introduce `maxContentLengthIO`. [issue #1588](https://github.com/yesodweb/yesod/issues/1588) and [PR #1589](https://github.com/yesodweb/yesod/pull/1589)++## 1.6.12++* Use at most one valid session cookie per request [#1581](https://github.com/yesodweb/yesod/pull/1581)++## 1.6.11++* Deprecate insecure JSON parsing functions [#1576](https://github.com/yesodweb/yesod/pull/1576)++## 1.6.10.1++* Fix test suite compilation for [commercialhaskell/stackage#4319](https://github.com/commercialhaskell/stackage/issues/4319)++## 1.6.10++* Adds functions to get and set values in the per-request caches. [#1573](https://github.com/yesodweb/yesod/pull/1573)++## 1.6.9++* Add `sendResponseNoContent` [#1565](https://github.com/yesodweb/yesod/pull/1565)++## 1.6.8.1++* Add missing test file to tarball [#1563](https://github.com/yesodweb/yesod/issues/1563)++## 1.6.8+* In the route syntax, allow trailing backslashes to indicate line+    continuation. [#1558](https://github.com/yesodweb/yesod/pull/1558)++## 1.6.7++* If no matches are found, `selectRep` chooses first representation regardless+    of the presence or absence of a `Content-Type` header in the request+    [#1540](https://github.com/yesodweb/yesod/pull/1540)+* Sets the `X-XSS-Protection` header to `1; mode=block` [#1550](https://github.com/yesodweb/yesod/pull/1550)+* Add `PrimMonad` instances for `HandlerFor` and `WidgetFor` [from+  StackOverflow](https://stackoverflow.com/q/52692508/369198)++## 1.6.6++* `defaultErrorHandler` handles text/plain requests [#1522](https://github.com/yesodweb/yesod/pull/1520)++## 1.6.5++* Add `fileSourceByteString` [#1503](https://github.com/yesodweb/yesod/pull/1503)++## 1.6.4++* Add `addContentDispositionFileName` [#1504](https://github.com/yesodweb/yesod/pull/1504)++## 1.6.3++* Add missing export for `SubHandlerFor`++## 1.6.2++* Derive a `Show` instance for `ResourceTree` and `FlatResource` [#1492](https://github.com/yesodweb/yesod/pull/1492)+	* Some third party packages, like `yesod-routes-flow` derive their own `Show` instance, and this will break those packages.++## 1.6.1++* Add a `Semigroup LiteApp` instance, and explicitly define `(<>)` in the+  already existing `Semigroup` instances for `WidgetFor`, `Head`, `Body`,+  `GWData`, and `UniqueList`.++## 1.6.0++* Upgrade to conduit 1.3.0+* Switch to `MonadUnliftIO`+* Drop `mwc-random` and `blaze-builder` dependencies+* Strictify some internal data structures+* Add `CI` wrapper to first field in `Header` data constructor+  [#1418](https://github.com/yesodweb/yesod/issues/1418)+* Internal only change, users of stable API are unaffected: `WidgetT`+  holds its data in an `IORef` so that it is isomorphic to `ReaderT`,+  avoiding state-loss issues..+* Overhaul of `HandlerT`/`WidgetT` to no longer be transformers.+* Fix Haddock comment & simplify implementation for `contentTypeTypes` [#1476](https://github.com/yesodweb/yesod/issues/1476)++## 1.4.37.3++* Improve error message when request body is too large [#1477](https://github.com/yesodweb/yesod/pull/1477)++## 1.4.37.2++* Improve error messages for the CSRF checking functions [#1455](https://github.com/yesodweb/yesod/issues/1455)++## 1.4.37.1++* Fix documentation on `languages` function, update `getMessageRender` to use said function. [#1457](https://github.com/yesodweb/yesod/pull/1457)++## 1.4.37++* Add `setWeakEtag` function in Yesod.Core.Handler module.++## 1.4.36++* Add `replaceOrAddHeader` function in Yesod.Core.Handler module. [1416](https://github.com/yesodweb/yesod/issues/1416)++## 1.4.35.1++* TH fix for GHC 8.2++## 1.4.35++* Contexts can be included in generated TH instances. [1365](https://github.com/yesodweb/yesod/issues/1365)+* Type variables can be included in routes.++## 1.4.34++* Add `WaiSubsiteWithAuth`. [#1394](https://github.com/yesodweb/yesod/pull/1394)++## 1.4.33++* Adds curly brackets to route parser. [#1363](https://github.com/yesodweb/yesod/pull/1363)++## 1.4.32++* Fix warnings+* Route parsing handles CRLF line endings+* Add 'getPostParams' in Yesod.Core.Handler+* Haddock rendering improved.++## 1.4.31++* Add `parseCheckJsonBody` and `requireCheckJsonBody`++## 1.4.30++* Add `defaultMessageWidget`++## 1.4.29++* Exports some internals and fix version bounds [#1318](https://github.com/yesodweb/yesod/pull/1318)++## 1.4.28++* Add ToWidget instances for strict text, lazy text, and text builder [#1310](https://github.com/yesodweb/yesod/pull/1310)++## 1.4.27++* Added `jsAttributes` [#1308](https://github.com/yesodweb/yesod/pull/1308)++## 1.4.26++* Modify `languages` so that, if you previously called `setLanguage`, the newly+  set language will be reflected.++## 1.4.25++* Add instance of MonadHandler and MonadWidget for ExceptT [#1278](https://github.com/yesodweb/yesod/pull/1278)++## 1.4.24++* cached and cachedBy will not overwrite global state changes [#1268](https://github.com/yesodweb/yesod/pull/1268)++## 1.4.23.1++* Don't allow sending multiple cookies with the same name to the client, in accordance with [RFC 6265](https://tools.ietf.org/html/rfc6265). This fixes an issue where multiple CSRF tokens were sent to the client. [#1258](https://github.com/yesodweb/yesod/pull/1258)+* Default CSRF tokens to the root path "/", fixing an issue where multiple tokens were stored in cookies, and using the wrong one led to CSRF errors [#1248](https://github.com/yesodweb/yesod/pull/1248)++## 1.4.23++* urlParamRenderOverride method for Yesod class [#1257](https://github.com/yesodweb/yesod/pull/1257)+* Add laxSameSiteSessions and strictSameSiteSessions [#1226](https://github.com/yesodweb/yesod/pull/1226)++## 1.4.22++* Proper handling of impure exceptions within `HandlerError` values++## 1.4.21++* Add support for `Encoding` from `aeson-0.11` [#1241](https://github.com/yesodweb/yesod/pull/1241)++## 1.4.20.2++* GHC 8 support++## 1.4.20.1++* Log a warning when a CSRF error occurs [#1200](https://github.com/yesodweb/yesod/pull/1200)++## 1.4.20++* `addMessage`, `addMessageI`, and `getMessages` functions++## 1.4.19.1++* Allow lines of dashes in route files [#1182](https://github.com/yesodweb/yesod/pull/1182)++## 1.4.19++* Auth logout not working with defaultCsrfMiddleware [#1151](https://github.com/yesodweb/yesod/issues/1151)++## 1.4.18.2++* Allow subsites within hierarchical routes [#1144](https://github.com/yesodweb/yesod/pull/1144)++## 1.4.18++* Add hook to apply arbitrary function to all handlers [#1122](https://github.com/yesodweb/yesod/pull/1122)++## 1.4.17++* Add `getApprootText`++## 1.4.16++* Add `guessApproot` and `guessApprootOr`++## 1.4.15.1++* bugfix neverExpires leaked threads++## 1.4.15++* mkYesod avoids using reify when it isn't necessary. This avoids needing to define the site type below the call to mkYesod.++## 1.4.14++* Add CSRF protection functions and middleware based on HTTP cookies and headers [#1017](https://github.com/yesodweb/yesod/pull/1017)+* Add mkYesodWith, which allows creating sites with polymorphic type parameters [#1055](https://github.com/yesodweb/yesod/pull/1055)+* Do not define the site type below a call to mkYesod (or any variant), as it will be required at splicing time for reification.+  This was allowed before because reification was not in use. Reification was introduced to allow parametrized types to be used+  by mkYesod (and variants), with potentially polymorphic variables.++## 1.4.13++* Add getsYesod function [#1042](https://github.com/yesodweb/yesod/pull/1042)+* Add IsString instance for WidgetT site m () [#1038](https://github.com/yesodweb/yesod/pull/1038)++## 1.4.12++* Don't show source location for logs that don't have that information [#1027](https://github.com/yesodweb/yesod/pull/1027)++## 1.4.11++* Expose `stripHandlerT` and `subHelper`++## 1.4.10++* Export log formatting [#1001](https://github.com/yesodweb/yesod/pull/1001)++## 1.4.9.1++* Deal better with multiple cookie headers++## 1.4.9++* Add simple authentication helpers [#962](https://github.com/yesodweb/yesod/pull/962)++## 1.4.8.3++* Use 307 redirect for cleaning paths and non-GET requests [#951](https://github.com/yesodweb/yesod/issues/951)++## 1.4.8.2++* Allow blaze-builder 0.4++## 1.4.8.1++* Bump upper bound on path-pieces++## 1.4.8++* Add a bunch of `Semigroup` instances++## 1.4.7.3++* Remove defunct reference to SpecialResponse [#925](https://github.com/yesodweb/yesod/issues/925)++## 1.4.7++SSL-only session security [#894](https://github.com/yesodweb/yesod/pull/894)++## 1.4.6.2++monad-control 1.0++## 1.4.6++Added the `Yesod.Core.Unsafe` module.++## 1.4.5++* `envClientSessionBackend`+* Add `MonadLoggerIO` instances (conditional on monad-logger 0.3.10 being used).++## 1.4.4.5++Support time 1.5++## 1.4.4.2++`neverExpires` uses dates one year in the future (instead of in 2037).++## 1.4.4.1++Improvements to etag/if-none-match support #868 #869++## 1.4.4++Add the `notModified` and `setEtag` functions.++## 1.4.3++Switch to mwc-random for token generation.
+ README.md view
@@ -0,0 +1,7 @@+## yesod-core++This is the main package for Yesod, providing all core functionality on which+other packages can be built. It provides dispatch, handler functions, widgets,+etc.++Yesod is well documented on [its website](http://www.yesodweb.com/).
− Yesod/Content.hs 
@@ -1,263 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Yesod.Content-    ( -- * Content-      Content (..)-    , emptyContent-    , ToContent (..)-      -- * Mime types-      -- ** Data type-    , ContentType-    , typeHtml-    , typePlain-    , typeJson-    , typeXml-    , typeAtom-    , typeRss-    , typeJpeg-    , typePng-    , typeGif-    , typeSvg-    , typeJavascript-    , typeCss-    , typeFlv-    , typeOgv-    , typeOctet-      -- * Utilities-    , simpleContentType-      -- * Evaluation strategy-    , DontFullyEvaluate (..)-      -- * Representations-    , ChooseRep-    , HasReps (..)-    , defChooseRep-      -- ** Specific content types-    , RepHtml (..)-    , RepJson (..)-    , RepHtmlJson (..)-    , RepPlain (..)-    , RepXml (..)-      -- * Utilities-    , formatW3-    , formatRFC1123-    , formatRFC822-    ) where--import Data.Maybe (mapMaybe)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Text.Lazy (Text, pack)-import qualified Data.Text as T--import Data.Time-import System.Locale--import qualified Data.Text.Encoding-import qualified Data.Text.Lazy.Encoding--import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)-import Data.Monoid (mempty)--import Text.Hamlet (Html)-import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)-import Data.String (IsString (fromString))-import Network.Wai (FilePart)-import Data.Conduit (Source, ResourceT, Flush)--import qualified Data.Aeson as J-import Data.Aeson.Encode (fromValue)-import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze-import Data.Text.Lazy.Builder (toLazyText)--data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length.-             | ContentSource !(Source (ResourceT IO) (Flush Builder))-             | ContentFile !FilePath !(Maybe FilePart)-             | ContentDontEvaluate !Content---- | Zero-length enumerator.-emptyContent :: Content-emptyContent = ContentBuilder mempty $ Just 0--instance IsString Content where-    fromString = toContent---- | Anything which can be converted into 'Content'. Most of the time, you will--- want to use the 'ContentBuilder' constructor. An easier approach will be to use--- a pre-defined 'toContent' function, such as converting your data into a lazy--- bytestring and then calling 'toContent' on that.------ Please note that the built-in instances for lazy data structures ('String',--- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include--- the content length for the 'ContentBuilder' constructor.-class ToContent a where-    toContent :: a -> Content--instance ToContent Builder where-    toContent = flip ContentBuilder Nothing-instance ToContent B.ByteString where-    toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs-instance ToContent L.ByteString where-    toContent = flip ContentBuilder Nothing . fromLazyByteString-instance ToContent T.Text where-    toContent = toContent . Data.Text.Encoding.encodeUtf8-instance ToContent Text where-    toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8-instance ToContent String where-    toContent = toContent . pack-instance ToContent Html where-    toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing---- | A function which gives targetted representations of content based on the--- content-types the user accepts.-type ChooseRep =-    [ContentType] -- ^ list of content-types user accepts, ordered by preference- -> IO (ContentType, Content)---- | Any type which can be converted to representations.-class HasReps a where-    chooseRep :: a -> ChooseRep---- | A helper method for generating 'HasReps' instances.------ This function should be given a list of pairs of content type and conversion--- functions. If none of the content types match, the first pair is used.-defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep-defChooseRep reps a ts = do-  let (ct, c) =-        case mapMaybe helper ts of-            (x:_) -> x-            [] -> case reps of-                    [] -> error "Empty reps to defChooseRep"-                    (x:_) -> x-  c' <- c a-  return (ct, c')-        where-            helper ct = do-                c <- lookup ct reps-                return (ct, c)--instance HasReps ChooseRep where-    chooseRep = id--instance HasReps () where-    chooseRep = defChooseRep [(typePlain, const $ return $ toContent B.empty)]--instance HasReps (ContentType, Content) where-    chooseRep = const . return--instance HasReps [(ContentType, Content)] where-    chooseRep a cts = return $-        case filter (\(ct, _) -> go ct `elem` map go cts) a of-            ((ct, c):_) -> (ct, c)-            _ -> case a of-                    (x:_) -> x-                    _ -> error "chooseRep [(ContentType, Content)] of empty"-      where-        go = simpleContentType--newtype RepHtml = RepHtml Content-instance HasReps RepHtml where-    chooseRep (RepHtml c) _ = return (typeHtml, c)-newtype RepJson = RepJson Content-instance HasReps RepJson where-    chooseRep (RepJson c) _ = return (typeJson, c)-data RepHtmlJson = RepHtmlJson Content Content-instance HasReps RepHtmlJson where-    chooseRep (RepHtmlJson html json) = chooseRep-        [ (typeHtml, html)-        , (typeJson, json)-        ]-newtype RepPlain = RepPlain Content-instance HasReps RepPlain where-    chooseRep (RepPlain c) _ = return (typePlain, c)-newtype RepXml = RepXml Content-instance HasReps RepXml where-    chooseRep (RepXml c) _ = return (typeXml, c)--type ContentType = B.ByteString -- FIXME Text?--typeHtml :: ContentType-typeHtml = "text/html; charset=utf-8"--typePlain :: ContentType-typePlain = "text/plain; charset=utf-8"--typeJson :: ContentType-typeJson = "application/json; charset=utf-8"--typeXml :: ContentType-typeXml = "text/xml"--typeAtom :: ContentType-typeAtom = "application/atom+xml"--typeRss :: ContentType-typeRss = "application/rss+xml"--typeJpeg :: ContentType-typeJpeg = "image/jpeg"--typePng :: ContentType-typePng = "image/png"--typeGif :: ContentType-typeGif = "image/gif"--typeSvg :: ContentType-typeSvg = "image/svg+xml"--typeJavascript :: ContentType-typeJavascript = "text/javascript; charset=utf-8"--typeCss :: ContentType-typeCss = "text/css; charset=utf-8"--typeFlv :: ContentType-typeFlv = "video/x-flv"--typeOgv :: ContentType-typeOgv = "video/ogg"--typeOctet :: ContentType-typeOctet = "application/octet-stream"---- | Removes \"extra\" information at the end of a content type string. In--- particular, removes everything after the semicolon, if present.------ For example, \"text/html; charset=utf-8\" is commonly used to specify the--- character encoding for HTML data. This function would return \"text/html\".-simpleContentType :: ContentType -> ContentType-simpleContentType = fst . B.breakByte 59 -- 59 == ;---- | Format a 'UTCTime' in W3 format.-formatW3 :: UTCTime -> T.Text-formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00"---- | Format as per RFC 1123.-formatRFC1123 :: UTCTime -> T.Text-formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"---- | Format as per RFC 822.-formatRFC822 :: UTCTime -> T.Text-formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"---- | Prevents a response body from being fully evaluated before sending the--- request.------ Since 1.1.0-newtype DontFullyEvaluate a = DontFullyEvaluate a--instance HasReps a => HasReps (DontFullyEvaluate a) where-    chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a--instance ToContent a => ToContent (DontFullyEvaluate a) where-    toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a--instance ToContent J.Value where-    toContent = flip ContentBuilder Nothing-              . Blaze.fromLazyText-              . toLazyText-              . fromValue
− Yesod/Core.hs 
@@ -1,75 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}-module Yesod.Core-    ( -- * Type classes-      Yesod (..)-    , YesodDispatch (..)-    , RenderRoute (..)-      -- ** Breadcrumbs-    , YesodBreadcrumbs (..)-    , breadcrumbs-      -- * Types-    , Approot (..)-    , FileUpload (..)-      -- * Utitlities-    , maybeAuthorized-    , widgetToPageContent-      -- * Defaults-    , defaultErrorHandler-      -- * Data types-    , AuthResult (..)-    , unauthorizedI-      -- * Logging-    , LogLevel (..)-    , logDebug-    , logInfo-    , logWarn-    , logError-    , logOther-    , logDebugS-    , logInfoS-    , logWarnS-    , logErrorS-    , logOtherS-      -- * Sessions-    , SessionBackend (..)-    , defaultClientSessionBackend-    , clientSessionBackend-    , clientSessionBackend2-    , clientSessionDateCacher-    , loadClientSession-    , Header(..)-    , BackendSession-    -- * JS loaders-    , loadJsYepnope-    , ScriptLoadPosition (..)-    , BottomOfHeadAsync-      -- * Misc-    , yesodVersion-    , yesodRender-    , runFakeHandler-      -- * Re-exports-    , module Yesod.Content-    , module Yesod.Dispatch-    , module Yesod.Handler-    , module Yesod.Request-    , module Yesod.Widget-    , module Yesod.Message-    ) where--import Yesod.Internal.Core-import Yesod.Internal (Header(..))-import Yesod.Content-import Yesod.Dispatch-import Yesod.Handler-import Yesod.Request-import Yesod.Widget-import Yesod.Message--import Control.Monad.Logger---- | Return an 'Unauthorized' value, with the given i18n message.-unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult-unauthorizedI msg =do-    mr <- getMessageRender-    return $ Unauthorized $ mr msg
− Yesod/Dispatch.hs 
@@ -1,223 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Yesod.Dispatch-    ( -- * Quasi-quoted routing-      parseRoutes-    , parseRoutesNoCheck-    , parseRoutesFile-    , parseRoutesFileNoCheck-    , mkYesod-    , mkYesodSub-      -- ** More fine-grained-    , mkYesodData-    , mkYesodSubData-    , mkYesodDispatch-    , mkYesodSubDispatch-    , mkDispatchInstance-      -- ** Path pieces-    , PathPiece (..)-    , PathMultiPiece (..)-    , Texts-      -- * Convert to WAI-    , toWaiApp-    , toWaiAppPlain-      -- * WAI subsites-    , WaiSubsite (..)-    ) where--import Control.Applicative ((<$>), (<*>))-import Prelude hiding (exp)-import Yesod.Internal.Core-import Yesod.Handler hiding (lift)-import Yesod.Widget (GWidget)--import Web.PathPieces-import Language.Haskell.TH-import Language.Haskell.TH.Syntax--import qualified Network.Wai as W-import Network.Wai.Middleware.Gzip-import Network.Wai.Middleware.Autohead--import Data.ByteString.Lazy.Char8 ()--import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Data.Monoid (mappend)-import qualified Data.ByteString as S-import qualified Blaze.ByteString.Builder-import Network.HTTP.Types (status301)-import Yesod.Routes.TH-import Yesod.Content (chooseRep)-import Yesod.Routes.Parse-import System.Log.FastLogger (Logger)--type Texts = [Text]---- | Generates URL datatype and site function for the given 'Resource's. This--- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.--- Use 'parseRoutes' to create the 'Resource's.-mkYesod :: String -- ^ name of the argument datatype-        -> [ResourceTree String]-        -> Q [Dec]-mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False---- | Generates URL datatype and site function for the given 'Resource's. This--- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter.--- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not--- executable by itself, but instead provides functionality to--- be embedded in other sites.-mkYesodSub :: String -- ^ name of the argument datatype-           -> Cxt-           -> [ResourceTree String]-           -> Q [Dec]-mkYesodSub name clazzes =-    fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True-  where-    (name':rest) = words name---- | Sometimes, you will want to declare your routes in one file and define--- your handlers elsewhere. For example, this is the only way to break up a--- monolithic file into smaller parts. Use this function, paired with--- 'mkYesodDispatch', to do just that.-mkYesodData :: String -> [ResourceTree String] -> Q [Dec]-mkYesodData name res = mkYesodDataGeneral name [] False res--mkYesodSubData :: String -> Cxt -> [ResourceTree String] -> Q [Dec]-mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res--mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec]-mkYesodDataGeneral name clazzes isSub res = do-    let (name':rest) = words name-    (x, _) <- mkYesodGeneral name' rest clazzes isSub res-    let rname = mkName $ "resources" ++ name-    eres <- lift res-    let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)-            , FunD rname [Clause [] (NormalB eres) []]-            ]-    return $ x ++ y---- | See 'mkYesodData'.-mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]-mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False--mkYesodSubDispatch :: String -> Cxt -> [ResourceTree String] -> Q [Dec]-mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True -  where (name':rest) = words name--mkYesodGeneral :: String                   -- ^ foundation type-               -> [String]                 -- ^ arguments for the type-               -> Cxt                      -- ^ the type constraints-               -> Bool                     -- ^ it this a subsite-               -> [ResourceTree String]-               -> Q([Dec],[Dec])-mkYesodGeneral name args clazzes isSub resS = do-     subsite        <- sub-     masterTypeSyns <- if isSub then return   [] -                                else sequence [handler, widget]-     renderRouteDec <- mkRenderRouteInstance subsite res-     dispatchDec    <- mkDispatchInstance context sub master res-     return (renderRouteDec ++ masterTypeSyns, dispatchDec)-  where sub     = foldl appT subCons subArgs-        master  = if isSub then (varT $ mkName "master") else sub-        context = if isSub then cxt $ yesod : map return clazzes-                           else return []-        yesod   = classP ''Yesod [master]-        handler = tySynD (mkName "Handler") [] [t| GHandler $master $master    |]-        widget  = tySynD (mkName "Widget")  [] [t| GWidget  $master $master () |]-        res     = map (fmap parseType) resS-        subCons = conT $ mkName name-        subArgs = map (varT. mkName) args-        --- | If the generation of @'YesodDispatch'@ instance require finer--- control of the types, contexts etc. using this combinator. You will--- hardly need this generality. However, in certain situations, like--- when writing library/plugin for yesod, this combinator becomes--- handy.-mkDispatchInstance :: CxtQ                -- ^ The context-                   -> TypeQ               -- ^ The subsite type-                   -> TypeQ               -- ^ The master site type-                   -> [ResourceTree a]    -- ^ The resource-                   -> DecsQ-mkDispatchInstance context sub master res = do-  logger <- newName "logger"-  let loggerE = varE logger-      loggerP = VarP logger-      yDispatch = conT ''YesodDispatch `appT` sub `appT` master-      thisDispatch = do-            Clause pat body decs <- mkDispatchClause-                                    [|yesodRunner   $loggerE |]-                                    [|yesodDispatch $loggerE |]-                                    [|fmap chooseRep|]-                                    res-            return $ FunD 'yesodDispatch-                         [ Clause (loggerP:pat)-                                  body-                                  decs-                         ]-      in sequence [instanceD context yDispatch [thisDispatch]]-        ---- | Convert the given argument into a WAI application, executable with any WAI--- handler. This is the same as 'toWaiAppPlain', except it includes two--- middlewares: GZIP compression and autohead. This is the--- recommended approach for most users.-toWaiApp :: ( Yesod master-            , YesodDispatch master master-            ) => master -> IO W.Application-toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y---- | Convert the given argument into a WAI application, executable with any WAI--- handler. This differs from 'toWaiApp' in that it uses no middlewares.-toWaiAppPlain :: ( Yesod master-                 , YesodDispatch master master-                 ) => master -> IO W.Application-toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a---toWaiApp' :: ( Yesod master-             , YesodDispatch master master-             )-          => master-          -> Logger-          -> Maybe (SessionBackend master)-          -> W.Application-toWaiApp' y logger sb env =-    case cleanPath y $ W.pathInfo env of-        Left pieces -> sendRedirect y pieces env-        Right pieces ->-            yesodDispatch logger y y id app404 handler405 method pieces sb env-  where-    app404 = yesodRunner logger notFound y y Nothing id-    handler405 route = yesodRunner logger badMethod y y (Just route) id-    method = decodeUtf8With lenientDecode $ W.requestMethod env--sendRedirect :: Yesod master => master -> [Text] -> W.Application-sendRedirect y segments' env =-     return $ W.responseLBS status301-            [ ("Content-Type", "text/plain")-            , ("Location", Blaze.ByteString.Builder.toByteString dest')-            ] "Redirecting"-  where-    dest = joinPath y (resolveApproot y env) segments' []-    dest' =-        if S.null (W.rawQueryString env)-            then dest-            else (dest `mappend`-                 Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))---- | Wrap up a normal WAI application as a Yesod subsite.-newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }--instance RenderRoute WaiSubsite where-    data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]-        deriving (Show, Eq, Read, Ord)-    renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)--instance YesodDispatch WaiSubsite master where-    yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
− Yesod/Handler.hs 
@@ -1,1071 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE DeriveDataTypeable #-}---------------------------------------------------------------- Module        : Yesod.Handler--- Copyright     : Michael Snoyman--- License       : BSD3------ Maintainer    : Michael Snoyman <michael@snoyman.com>--- Stability     : stable--- Portability   : portable------ Define Handler stuff.--------------------------------------------------------------module Yesod.Handler-    ( -- * Type families-      YesodSubRoute (..)-      -- * Handler monad-    , GHandler-      -- ** Read information from handler-    , getYesod-    , getYesodSub-    , getUrlRender-    , getUrlRenderParams-    , getCurrentRoute-    , getRouteToMaster-    , getRequest-    , waiRequest-    , runRequestBody-      -- * Special responses-      -- ** Redirecting-    , RedirectUrl (..)-    , redirect-    , redirectWith-    , redirectToPost-      -- ** Errors-    , notFound-    , badMethod-    , permissionDenied-    , permissionDeniedI-    , invalidArgs-    , invalidArgsI-      -- ** Short-circuit responses.-    , sendFile-    , sendFilePart-    , sendResponse-    , sendResponseStatus-    , sendResponseCreated-    , sendWaiResponse-      -- * Setting headers-    , setCookie-    , getExpires-    , deleteCookie-    , setHeader-    , setLanguage-      -- ** Content caching and expiration-    , cacheSeconds-    , neverExpires-    , alreadyExpired-    , expiresAt-      -- * Session-    , SessionMap-    , lookupSession-    , lookupSessionBS-    , getSession-    , setSession-    , setSessionBS-    , deleteSession-    , clearSession-      -- ** Ultimate destination-    , setUltDest-    , setUltDestCurrent-    , setUltDestReferer-    , redirectUltDest-    , clearUltDest-      -- ** Messages-    , setMessage-    , setMessageI-    , getMessage-      -- * Helpers for specific content-      -- ** Hamlet-    , hamletToContent-    , hamletToRepHtml-      -- ** Misc-    , newIdent-      -- * Lifting-    , MonadLift (..)-    , handlerToIO-      -- * i18n-    , getMessageRender-      -- * Per-request caching-    , CacheKey-    , mkCacheKey-    , cacheLookup-    , cacheInsert-    , cacheDelete-      -- * Internal Yesod-    , runHandler-    , YesodApp (..)-    , runSubsiteGetter-    , toMasterHandler-    , toMasterHandlerDyn-    , toMasterHandlerMaybe-    , localNoCurrent-    , HandlerData-    , ErrorResponse (..)-    , YesodAppResult (..)-    , handlerToYAR-    , yarToResponse-    , headerToPair-    ) where--import Prelude hiding (catch)-import Yesod.Internal.Request-import Yesod.Internal-import Data.Time (UTCTime, getCurrentTime, addUTCTime)--import Control.Exception hiding (Handler, catch, finally)-import Control.Applicative--import Control.Monad (liftM)-import Control.Failure (Failure (failure))--import Control.Monad.IO.Class-import Control.Monad.Trans.Class (MonadTrans)-import qualified Control.Monad.Trans.Class--import System.IO-import qualified Network.Wai as W-import qualified Network.HTTP.Types as H--import Text.Hamlet-import qualified Text.Blaze.Html.Renderer.Text as RenderText-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8, decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import qualified Data.Text.Lazy as TL--import qualified Data.Map as Map-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Network.Wai.Parse (parseHttpAccept)--import Yesod.Content-import Data.Maybe (fromMaybe, mapMaybe)-import Web.Cookie (SetCookie (..), renderSetCookie)-import Control.Arrow ((***))-import qualified Network.Wai.Parse as NWP-import Data.Monoid (mappend, mempty, Endo (..))-import qualified Data.ByteString.Char8 as S8-import Data.ByteString (ByteString)-import Data.CaseInsensitive (CI)-import qualified Data.CaseInsensitive as CI-import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString)-import Data.Text (Text)-import Yesod.Message (RenderMessage (..))--import Text.Blaze.Html (toHtml, preEscapedToMarkup)-#define preEscapedText preEscapedToMarkup--import System.Log.FastLogger-import Control.Monad.Logger--import qualified Yesod.Internal.Cache as Cache-import Yesod.Internal.Cache (mkCacheKey, CacheKey)-import qualified Data.IORef as I-import Control.Exception.Lifted (catch)-import Control.Monad.Trans.Control-import Control.Monad.Trans.Resource-import Control.Monad.Base-import Yesod.Routes.Class-import Data.Word (Word64)-import Language.Haskell.TH.Syntax (Loc)--class YesodSubRoute s y where-    fromSubRoute :: s -> y -> Route s -> Route y--data HandlerData sub master = HandlerData-    { handlerRequest  :: Request-    , handlerSub      :: sub-    , handlerMaster   :: master-    , handlerRoute    :: Maybe (Route sub)-    , handlerRender   :: Route master -> [(Text, Text)] -> Text-    , handlerToMaster :: Route sub -> Route master-    , handlerState    :: I.IORef GHState-    , handlerUpload   :: Word64 -> FileUpload-    , handlerLog      :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()-    }--handlerSubData :: (Route sub -> Route master)-               -> (master -> sub)-               -> Route sub-               -> HandlerData oldSub master-               -> HandlerData sub master-handlerSubData tm ts = handlerSubDataMaybe tm ts . Just--handlerSubDataMaybe :: (Route sub -> Route master)-                    -> (master -> sub)-                    -> Maybe (Route sub)-                    -> HandlerData oldSub master-                    -> HandlerData sub master-handlerSubDataMaybe tm ts route hd = hd-    { handlerSub = ts $ handlerMaster hd-    , handlerToMaster = tm-    , handlerRoute = route-    }--get :: GHandler sub master GHState-get = do-    hd <- ask-    liftIO $ I.readIORef $ handlerState hd--put :: GHState -> GHandler sub master ()-put g = do-    hd <- ask-    liftIO $ I.writeIORef (handlerState hd) g--modify :: (GHState -> GHState) -> GHandler sub master ()-modify f = do-    hd <- ask-    liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ())--tell :: Endo [Header] -> GHandler sub master ()-tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }---- | Used internally for promoting subsite handler functions to master site--- handler functions. Should not be needed by users.-toMasterHandler :: (Route sub -> Route master)-                -> (master -> sub)-                -> Route sub-                -> GHandler sub master a-                -> GHandler sub' master a-toMasterHandler tm ts route = local (handlerSubData tm ts route)---- | FIXME do we need this?-toMasterHandlerDyn :: (Route sub -> Route master)-                   -> GHandler sub' master sub-                   -> Route sub-                   -> GHandler sub master a-                   -> GHandler sub' master a-toMasterHandlerDyn tm getSub route h = do-    sub <- getSub-    local (handlerSubData tm (const sub) route) h--class SubsiteGetter g m s | g -> s where-  runSubsiteGetter :: g -> m s--instance (master ~ master'-         ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where-  runSubsiteGetter getter = getter <$> getYesod--instance (anySub ~ anySub'-         ,master ~ master'-         ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where-  runSubsiteGetter = id--toMasterHandlerMaybe :: (Route sub -> Route master)-                     -> (master -> sub)-                     -> Maybe (Route sub)-                     -> GHandler sub master a-                     -> GHandler sub' master a-toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route)---- | A generic handler monad, which can have a different subsite and master--- site. We define a newtype for better error message.-newtype GHandler sub master a = GHandler-    { unGHandler :: HandlerData sub master -> ResourceT IO a-    }--data GHState = GHState-    { ghsSession :: SessionMap-    , ghsRBC :: Maybe RequestBodyContents-    , ghsIdent :: Int-    , ghsCache :: Cache.Cache-    , ghsHeaders :: Endo [Header]-    }--type SessionMap = Map.Map Text S.ByteString---- | An extension of the basic WAI 'W.Application' datatype to provide extra--- features needed by Yesod. Users should never need to use this directly, as--- the 'GHandler' monad and template haskell code should hide it away.-newtype YesodApp = YesodApp-    { unYesodApp-    :: (ErrorResponse -> YesodApp)-    -> Request-    -> [ContentType]-    -> SessionMap-    -> ResourceT IO YesodAppResult-    }--data YesodAppResult-    = YARWai W.Response-    | YARPlain H.Status [Header] ContentType Content SessionMap--getRequest :: GHandler s m Request-getRequest = handlerRequest `liftM` ask--hcError :: ErrorResponse -> GHandler sub master a-hcError = liftIO . throwIO . HCError--runRequestBody :: GHandler s m RequestBodyContents-runRequestBody = do-    hd <- ask-    let getUpload = handlerUpload hd-        len = reqBodySize $ handlerRequest hd-        upload = getUpload len-    x <- get-    case ghsRBC x of-        Just rbc -> return rbc-        Nothing -> do-            rr <- waiRequest-            rbc <- lift $ rbHelper upload rr-            put x { ghsRBC = Just rbc }-            return rbc--rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents-rbHelper upload =-    case upload of-        FileUploadMemory s -> rbHelper' s mkFileInfoLBS-        FileUploadDisk s -> rbHelper' s mkFileInfoFile-        FileUploadSource s -> rbHelper' s mkFileInfoSource--rbHelper' :: NWP.BackEnd x-          -> (Text -> Text -> x -> FileInfo)-          -> W.Request-          -> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])-rbHelper' backend mkFI req =-    (map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req)-  where-    fix1 = go *** go-    fix2 (x, NWP.FileInfo a' b c)-        | S.null a = Nothing-        | otherwise = Just (go x, mkFI (go a) (go b) c)-      where-        a-            | S.length a' < 2 = a'-            | S8.head a' == '"' && S8.last a' == '"' = S.tail $ S.init a'-            | S8.head a' == '\'' && S8.last a' == '\'' = S.tail $ S.init a'-            | otherwise = a'-    go = decodeUtf8With lenientDecode---- | Get the sub application argument.-getYesodSub :: GHandler sub master sub-getYesodSub = handlerSub `liftM` ask---- | Get the master site appliation argument.-getYesod :: GHandler sub master master-getYesod = handlerMaster `liftM` ask---- | Get the URL rendering function.-getUrlRender :: GHandler sub master (Route master -> Text)-getUrlRender = do-    x <- handlerRender `liftM` ask-    return $ flip x []---- | The URL rendering function with query-string parameters.-getUrlRenderParams-    :: GHandler sub master (Route master -> [(Text, Text)] -> Text)-getUrlRenderParams = handlerRender `liftM` ask---- | Get the route requested by the user. If this is a 404 response- where the--- user requested an invalid route- this function will return 'Nothing'.-getCurrentRoute :: GHandler sub master (Maybe (Route sub))-getCurrentRoute = handlerRoute `liftM` ask---- | Get the function to promote a route for a subsite to a route for the--- master site.-getRouteToMaster :: GHandler sub master (Route sub -> Route master)-getRouteToMaster = handlerToMaster `liftM` ask----- | Returns a function that runs 'GHandler' actions inside @IO@.------ Sometimes you want to run an inner 'GHandler' action outside--- the control flow of an HTTP request (on the outer 'GHandler'--- action).  For example, you may want to spawn a new thread:------ @--- getFooR :: Handler RepHtml--- getFooR = do---   runInnerHandler <- handlerToIO---   liftIO $ forkIO $ runInnerHandler $ do---     /Code here runs inside GHandler but on a new thread./---     /This is the inner GHandler./---     ...---   /Code here runs inside the request's control flow./---   /This is the outer GHandler./---   ...--- @------ Another use case for this function is creating a stream of--- server-sent events using 'GHandler' actions (see--- @yesod-eventsource@).------ Most of the environment from the outer 'GHandler' is preserved--- on the inner 'GHandler', however:------  * The request body is cleared (otherwise it would be very---  difficult to prevent huge memory leaks).------  * The cache is cleared (see 'CacheKey').------ Changes to the response made inside the inner 'GHandler' are--- ignored (e.g., session variables, cookies, response headers).--- This allows the inner 'GHandler' to outlive the outer--- 'GHandler' (e.g., on the @forkIO@ example above, a response--- may be sent to the client without killing the new thread).-handlerToIO :: MonadIO m => GHandler sub master (GHandler sub master a -> m a)-handlerToIO =-  GHandler $ \oldHandlerData -> do-    -- Let go of the request body, cache and response headers.-    let oldReq    = handlerRequest oldHandlerData-        oldWaiReq = reqWaiRequest oldReq-        newWaiReq = oldWaiReq { W.requestBody = mempty }-        newReq    = oldReq { reqWaiRequest = newWaiReq-                           , reqBodySize   = 0 }-        clearedOldHandlerData =-          oldHandlerData { handlerRequest = err "handlerRequest never here"-                         , handlerState   = err "handlerState never here" }-            where-              err :: String -> a-              err = error . ("handlerToIO: clearedOldHandlerData/" ++)-    newState <- liftIO $ do-      oldState <- I.readIORef (handlerState oldHandlerData)-      return $ oldState { ghsRBC = Nothing-                        , ghsIdent = 1-                        , ghsCache = mempty-                        , ghsHeaders = mempty }--    -- Return GHandler running function.-    return $ \(GHandler f) -> liftIO $ do-      -- The state IORef needs to be created here, otherwise it-      -- will be shared by different invocations of this function.-      newStateIORef <- I.newIORef newState-      runResourceT $ f clearedOldHandlerData-                         { handlerRequest = newReq-                         , handlerState   = newStateIORef }----- | Function used internally by Yesod in the process of converting a--- 'GHandler' into an 'W.Application'. Should not be needed by users.-runHandler :: HasReps c-           => GHandler sub master c-           -> (Route master -> [(Text, Text)] -> Text)-           -> Maybe (Route sub)-           -> (Route sub -> Route master)-           -> master-           -> sub-           -> (Word64 -> FileUpload)-           -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())-           -> YesodApp-runHandler handler mrender sroute tomr master sub upload log' =-  YesodApp $ \eh rr cts initSession -> do-    let toErrorHandler e =-            case fromException e of-                Just x -> x-                Nothing -> InternalError $ T.pack $ show e-    istate <- liftIO $ I.newIORef GHState-        { ghsSession = initSession-        , ghsRBC = Nothing-        , ghsIdent = 1-        , ghsCache = mempty-        , ghsHeaders = mempty-        }-    let hd = HandlerData-            { handlerRequest = rr-            , handlerSub = sub-            , handlerMaster = master-            , handlerRoute = sroute-            , handlerRender = mrender-            , handlerToMaster = tomr-            , handlerState = istate-            , handlerUpload = upload-            , handlerLog = log'-            }-    contents' <- catch (fmap Right $ unGHandler handler hd)-        (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id-                      $ fromException e)-    state <- liftIO $ I.readIORef istate-    let finalSession = ghsSession state-    let headers = ghsHeaders state-    let contents = either id (HCContent H.status200 . chooseRep) contents'-    let handleError e = do-            yar <- unYesodApp (eh e) safeEh rr cts finalSession-            case yar of-                YARPlain _ hs ct c sess ->-                    let hs' = appEndo headers hs-                     in return $ YARPlain (getStatus e) hs' ct c sess-                YARWai _ -> return yar-    let sendFile' ct fp p =-            return $ YARPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession-    case contents of-        HCContent status a -> do-            (ct, c) <- liftIO $ a cts-            ec' <- liftIO $ evaluateContent c-            case ec' of-                Left e -> handleError e-                Right c' -> return $ YARPlain status (appEndo headers []) ct c' finalSession-        HCError e -> handleError e-        HCRedirect status loc -> do-            let disable_caching x =-                      Header "Cache-Control" "no-cache, must-revalidate"-                    : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"-                    : x-                hs = (if status /= H.movedPermanently301 then disable_caching else id)-                      $ Header "Location" (encodeUtf8 loc) : appEndo headers []-            return $ YARPlain-                status hs typePlain emptyContent-                finalSession-        HCSendFile ct fp p -> catch-            (sendFile' ct fp p)-            (handleError . toErrorHandler)-        HCCreated loc -> do-            let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []-            return $ YARPlain-                H.status201-                hs-                typePlain-                emptyContent-                finalSession-        HCWai r -> return $ YARWai r--evaluateContent :: Content -> IO (Either ErrorResponse Content)-evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do-    let lbs = toLazyByteString b-    L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)-  where-    f :: SomeException -> IO (Either ErrorResponse Content)-    f = return . Left . InternalError . T.pack . show-evaluateContent c = return (Right c)--safeEh :: ErrorResponse -> YesodApp-safeEh er = YesodApp $ \_ _ _ session -> do-    liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er-    return $ YARPlain-        H.status500-        []-        typePlain-        (toContent ("Internal Server Error" :: S.ByteString))-        session---- | Redirect to the given route.--- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0--- This is the appropriate choice for a get-following-post--- technique, which should be the usual use case.------ If you want direct control of the final status code, or need a different--- status code, please use 'redirectWith'.-redirect :: RedirectUrl master url => url -> GHandler sub master a-redirect url = do-    req <- waiRequest-    let status =-            if W.httpVersion req == H.http11-                then H.status303-                else H.status302-    redirectWith status url---- | Redirect to the given URL with the specified status code.-redirectWith :: RedirectUrl master url => H.Status -> url -> GHandler sub master a-redirectWith status url = do-    urlText <- toTextUrl url-    liftIO $ throwIO $ HCRedirect status urlText--ultDestKey :: Text-ultDestKey = "_ULT"---- | Sets the ultimate destination variable to the given route.------ An ultimate destination is stored in the user session and can be loaded--- later by 'redirectUltDest'.-setUltDest :: RedirectUrl master url => url -> GHandler sub master ()-setUltDest url = do-    urlText <- toTextUrl url-    setSession ultDestKey urlText---- | Same as 'setUltDest', but uses the current page.------ If this is a 404 handler, there is no current page, and then this call does--- nothing.-setUltDestCurrent :: GHandler sub master ()-setUltDestCurrent = do-    route <- getCurrentRoute-    case route of-        Nothing -> return ()-        Just r -> do-            tm <- getRouteToMaster-            gets' <- reqGetParams `liftM` handlerRequest `liftM` ask-            setUltDest (tm r, gets')---- | Sets the ultimate destination to the referer request header, if present.------ This function will not overwrite an existing ultdest.-setUltDestReferer :: GHandler sub master ()-setUltDestReferer = do-    mdest <- lookupSession ultDestKey-    maybe-        (waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)-        (const $ return ())-        mdest-  where-    setUltDestBS = setUltDest . T.pack . S8.unpack---- | Redirect to the ultimate destination in the user's session. Clear the--- value from the session.------ The ultimate destination is set with 'setUltDest'.------ This function uses 'redirect', and thus will perform a temporary redirect to--- a GET request.-redirectUltDest :: RedirectUrl master url-                => url -- ^ default destination if nothing in session-                -> GHandler sub master a-redirectUltDest def = do-    mdest <- lookupSession ultDestKey-    deleteSession ultDestKey-    maybe (redirect def) redirect mdest---- | Remove a previously set ultimate destination. See 'setUltDest'.-clearUltDest :: GHandler sub master ()-clearUltDest = deleteSession ultDestKey--msgKey :: Text-msgKey = "_MSG"---- | Sets a message in the user's session.------ See 'getMessage'.-setMessage :: Html -> GHandler sub master ()-setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml---- | Sets a message in the user's session.------ See 'getMessage'.-setMessageI :: (RenderMessage y msg) => msg -> GHandler sub y ()-setMessageI msg = do-    mr <- getMessageRender-    setMessage $ toHtml $ mr msg---- | Gets the message in the user's session, if available, and then clears the--- variable.------ See 'setMessage'.-getMessage :: GHandler sub master (Maybe Html)-getMessage = do-    mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey-    deleteSession msgKey-    return mmsg---- | Bypass remaining handler code and output the given file.------ For some backends, this is more efficient than reading in the file to--- memory, since they can optimize file sending via a system call to sendfile.-sendFile :: ContentType -> FilePath -> GHandler sub master a-sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing---- | Same as 'sendFile', but only sends part of a file.-sendFilePart :: ContentType-             -> FilePath-             -> Integer -- ^ offset-             -> Integer -- ^ count-             -> GHandler sub master a-sendFilePart ct fp off count =-    liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count---- | Bypass remaining handler code and output the given content with a 200--- status code.-sendResponse :: HasReps c => c -> GHandler sub master a-sendResponse = liftIO . throwIO . HCContent H.status200-             . chooseRep---- | Bypass remaining handler code and output the given content with the given--- status code.-sendResponseStatus :: HasReps c => H.Status -> c -> GHandler s m a-sendResponseStatus s = liftIO . throwIO . HCContent s-                     . chooseRep---- | Send a 201 "Created" response with the given route as the Location--- response header.-sendResponseCreated :: Route m -> GHandler s m a-sendResponseCreated url = do-    r <- getUrlRender-    liftIO . throwIO $ HCCreated $ r url---- | Send a 'W.Response'. Please note: this function is rarely--- necessary, and will /disregard/ any changes to response headers and session--- that you have already specified. This function short-circuits. It should be--- considered only for very specific needs. If you are not sure if you need it,--- you don't.-sendWaiResponse :: W.Response -> GHandler s m b-sendWaiResponse = liftIO . throwIO . HCWai---- | Return a 404 not found page. Also denotes no handler available.-notFound :: GHandler sub master a-notFound = hcError NotFound---- | Return a 405 method not supported page.-badMethod :: GHandler sub master a-badMethod = do-    w <- waiRequest-    hcError $ BadMethod $ W.requestMethod w---- | Return a 403 permission denied page.-permissionDenied :: Text -> GHandler sub master a-permissionDenied = hcError . PermissionDenied---- | Return a 403 permission denied page.-permissionDeniedI :: RenderMessage master msg => msg -> GHandler sub master a-permissionDeniedI msg = do-    mr <- getMessageRender-    permissionDenied $ mr msg---- | Return a 400 invalid arguments page.-invalidArgs :: [Text] -> GHandler sub master a-invalidArgs = hcError . InvalidArgs---- | Return a 400 invalid arguments page.-invalidArgsI :: RenderMessage y msg => [msg] -> GHandler s y a-invalidArgsI msg = do-    mr <- getMessageRender-    invalidArgs $ map mr msg--------- Headers--- | Set the cookie on the client.--setCookie :: SetCookie-          -> GHandler sub master ()-setCookie = addHeader . AddCookie---- | Helper function for setCookieExpires value-getExpires :: Int -- ^ minutes-          -> IO UTCTime-getExpires m = do-    now <- liftIO getCurrentTime-    return $ fromIntegral (m * 60) `addUTCTime` now----- | Unset the cookie on the client.------ Note: although the value used for key and path is 'Text', you should only--- use ASCII values to be HTTP compliant.-deleteCookie :: Text -- ^ key-             -> Text -- ^ path-             -> GHandler sub master ()-deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8----- | Set the language in the user session. Will show up in 'languages' on the--- next request.-setLanguage :: Text -> GHandler sub master ()-setLanguage = setSession langKey---- | Set an arbitrary response header.------ Note that, while the data type used here is 'Text', you must provide only--- ASCII value to be HTTP compliant.-setHeader :: Text -> Text -> GHandler sub master ()-setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8---- | Set the Cache-Control header to indicate this response should be cached--- for the given number of seconds.-cacheSeconds :: Int -> GHandler s m ()-cacheSeconds i = setHeader "Cache-Control" $ T.concat-    [ "max-age="-    , T.pack $ show i-    , ", public"-    ]---- | Set the Expires header to some date in 2037. In other words, this content--- is never (realistically) expired.-neverExpires :: GHandler s m ()-neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"---- | Set an Expires header in the past, meaning this content should not be--- cached.-alreadyExpired :: GHandler s m ()-alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"---- | Set an Expires header to the given date.-expiresAt :: UTCTime -> GHandler s m ()-expiresAt = setHeader "Expires" . formatRFC1123---- | Set a variable in the user's session.------ The session is handled by the clientsession package: it sets an encrypted--- and hashed cookie on the client. This ensures that all data is secure and--- not tampered with.-setSession :: Text -- ^ key-           -> Text -- ^ value-           -> GHandler sub master ()-setSession k = setSessionBS k . encodeUtf8---- | Same as 'setSession', but uses binary data for the value.-setSessionBS :: Text-             -> S.ByteString-             -> GHandler sub master ()-setSessionBS k = modify . modSession . Map.insert k---- | Unsets a session variable. See 'setSession'.-deleteSession :: Text -> GHandler sub master ()-deleteSession = modify . modSession . Map.delete---- | Clear all session variables.------ Since: 1.0.1-clearSession :: GHandler sub master ()-clearSession = modify $ \x -> x { ghsSession = Map.empty }--modSession :: (SessionMap -> SessionMap) -> GHState -> GHState-modSession f x = x { ghsSession = f $ ghsSession x }---- | Internal use only, not to be confused with 'setHeader'.-addHeader :: Header -> GHandler sub master ()-addHeader = tell . Endo . (:)--getStatus :: ErrorResponse -> H.Status-getStatus NotFound = H.status404-getStatus (InternalError _) = H.status500-getStatus (InvalidArgs _) = H.status400-getStatus (PermissionDenied _) = H.status403-getStatus (BadMethod _) = H.status405---- | Some value which can be turned into a URL for redirects.-class RedirectUrl master a where-    -- | Converts the value to the URL and a list of query-string parameters.-    toTextUrl :: a -> GHandler sub master Text--instance RedirectUrl master Text where-    toTextUrl = return--instance RedirectUrl master String where-    toTextUrl = toTextUrl . T.pack--instance RedirectUrl master (Route master) where-    toTextUrl url = do-        r <- getUrlRender-        return $ r url--instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where-    toTextUrl (url, params) = do-        r <- getUrlRenderParams-        return $ r url params--localNoCurrent :: GHandler s m a -> GHandler s m a-localNoCurrent =-    local (\hd -> hd { handlerRoute = Nothing })---- | Lookup for session data.-lookupSession :: Text -> GHandler s m (Maybe Text)-lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS---- | Lookup for session data in binary format.-lookupSessionBS :: Text -> GHandler s m (Maybe S.ByteString)-lookupSessionBS n = do-    m <- liftM ghsSession get-    return $ Map.lookup n m---- | Get all session variables.-getSession :: GHandler sub master SessionMap-getSession = liftM ghsSession get--handlerToYAR :: (HasReps a, HasReps b)-             => master -- ^ master site foundation-             -> sub    -- ^ sub site foundation-             -> (Word64 -> FileUpload)-             -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())-             -> (Route sub -> Route master)-             -> (Route master -> [(Text, Text)] -> Text) -- route renderer-             -> (ErrorResponse -> GHandler sub master a)-             -> Request-             -> Maybe (Route sub)-             -> SessionMap-             -> GHandler sub master b-             -> ResourceT IO YesodAppResult-handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h =-    unYesodApp ya eh' rr types sessionMap-  where-    ya = runHandler h render murl toMasterRoute y s upload log'-    eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log'-    types = httpAccept $ reqWaiRequest rr-    errorHandler' = localNoCurrent . errorHandler--yarToResponse :: YesodAppResult -> [(CI ByteString, ByteString)] -> W.Response-yarToResponse (YARWai a) _ = a-yarToResponse (YARPlain s hs _ c _) extraHeaders =-    go c-  where-    finalHeaders = extraHeaders ++ map headerToPair hs-    finalHeaders' len = ("Content-Length", S8.pack $ show len)-                      : finalHeaders--    go (ContentBuilder b mlen) =-        W.ResponseBuilder s hs' b-      where-        hs' = maybe finalHeaders finalHeaders' mlen-    go (ContentFile fp p) = W.ResponseFile s finalHeaders fp p-    go (ContentSource body) = W.ResponseSource s finalHeaders body-    go (ContentDontEvaluate c') = go c'--httpAccept :: W.Request -> [ContentType]-httpAccept = parseHttpAccept-           . fromMaybe mempty-           . lookup "Accept"-           . W.requestHeaders---- | Convert Header to a key/value pair.-headerToPair :: Header-             -> (CI ByteString, ByteString)-headerToPair (AddCookie sc) =-    ("Set-Cookie", toByteString $ renderSetCookie $ sc)-headerToPair (DeleteCookie key path) =-    ( "Set-Cookie"-    , S.concat-        [ key-        , "=; path="-        , path-        , "; expires=Thu, 01-Jan-1970 00:00:00 GMT"-        ]-    )-headerToPair (Header key value) = (CI.mk key, value)---- | Get a unique identifier.-newIdent :: GHandler sub master Text-newIdent = do-    x <- get-    let i' = ghsIdent x + 1-    put x { ghsIdent = i' }-    return $ T.pack $ 'h' : show i'---- | Redirect to a POST resource.------ This is not technically a redirect; instead, it returns an HTML page with a--- POST form, and some Javascript to automatically submit the form. This can be--- useful when you need to post a plain link somewhere that needs to cause--- changes on the server.-redirectToPost :: RedirectUrl master url => url -> GHandler sub master a-redirectToPost url = do-    urlText <- toTextUrl url-    hamletToRepHtml [hamlet|-$newline never-$doctype 5--<html>-    <head>-        <title>Redirecting...-    <body onload="document.getElementById('form').submit()">-        <form id="form" method="post" action=#{urlText}>-            <noscript>-                <p>Javascript has been disabled; please click on the button below to be redirected.-            <input type="submit" value="Continue">-|] >>= sendResponse---- | Converts the given Hamlet template into 'Content', which can be used in a--- Yesod 'Response'.-hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content-hamletToContent h = do-    render <- getUrlRenderParams-    return $ toContent $ h render---- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.-hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml-hamletToRepHtml = liftM RepHtml . hamletToContent---- | Get the request\'s 'W.Request' value.-waiRequest :: GHandler sub master W.Request-waiRequest = reqWaiRequest `liftM` getRequest--getMessageRender :: RenderMessage master message => GHandler s master (message -> Text)-getMessageRender = do-    m <- getYesod-    l <- reqLangs `liftM` getRequest-    return $ renderMessage m l--cacheLookup :: CacheKey a -> GHandler sub master (Maybe a)-cacheLookup k = do-    gs <- get-    return $ Cache.lookup k $ ghsCache gs--cacheInsert :: CacheKey a -> a -> GHandler sub master ()-cacheInsert k v = modify $ \gs ->-    gs { ghsCache = Cache.insert k v $ ghsCache gs }--cacheDelete :: CacheKey a -> GHandler sub master ()-cacheDelete k = modify $ \gs ->-    gs { ghsCache = Cache.delete k $ ghsCache gs }--ask :: GHandler sub master (HandlerData sub master)-ask = GHandler return--local :: (HandlerData sub' master' -> HandlerData sub master)-      -> GHandler sub master a-      -> GHandler sub' master' a-local f (GHandler x) = GHandler $ \r -> x $ f r---- | The standard @MonadTrans@ class only allows lifting for monad--- transformers. While @GHandler@ and @GWidget@ should allow lifting, their--- types do not express that they actually are transformers. This replacement--- class accounts for this.-class MonadLift base m | m -> base where-    lift :: base a -> m a-instance (Monad m, MonadTrans t) => MonadLift m (t m) where-    lift = Control.Monad.Trans.Class.lift-instance MonadLift (ResourceT IO) (GHandler sub master) where-    lift = GHandler . const---- Instances for GHandler-instance Functor (GHandler sub master) where-    fmap f (GHandler x) = GHandler $ \r -> fmap f (x r)-instance Applicative (GHandler sub master) where-    pure = GHandler . const . pure-    GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r-instance Monad (GHandler sub master) where-    return = pure-    GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r-instance MonadIO (GHandler sub master) where-    liftIO = GHandler . const . lift-instance MonadBase IO (GHandler sub master) where-    liftBase = GHandler . const . lift--- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s--- @fork@ function is incompatible with the underlying @ResourceT@ system.--- Instead, if you must fork a separate thread, you should use--- @resourceForkIO@.------ Using fork usually leads to an exception that says--- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed--- after cleanup. Please contact the maintainers.\"-instance MonadBaseControl IO (GHandler sub master) where-    data StM (GHandler sub master) a = StH (StM (ResourceT IO) a)-    liftBaseWith f = GHandler $ \reader ->-        liftBaseWith $ \runInBase ->-            f $ liftM StH . runInBase . (\(GHandler r) -> r reader)-    restoreM (StH base) = GHandler $ const $ restoreM base--instance MonadUnsafeIO (GHandler sub master) where-    unsafeLiftIO = liftIO-instance MonadThrow (GHandler sub master) where-    monadThrow = liftIO . throwIO-instance MonadResource (GHandler sub master) where-#if MIN_VERSION_resourcet(0,4,0)-    liftResourceT = lift . liftResourceT-#else-    allocate a = lift . allocate a-    register = lift . register-    release = lift . release-    resourceMask = lift . resourceMask-#endif--instance MonadLogger (GHandler sub master) where-#if MIN_VERSION_monad_logger(0, 3, 0)-    monadLoggerLog a b c d = do-        hd <- ask-        liftIO $ handlerLog hd a b c (toLogStr d)-#else-    monadLoggerLog a c d = monadLoggerLogSource a "" c d-    monadLoggerLogSource a b c d = do-        hd <- ask-        liftIO $ handlerLog hd a b c (toLogStr d)-#endif--instance Exception e => Failure e (GHandler sub master) where-    failure = liftIO . throwIO
− Yesod/Internal.hs 
@@ -1,138 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}--- | Normal users should never need access to these.------ Note that no guarantees of API stability are provided on this module. Use at your own risk.-module Yesod.Internal-    ( -- * Error responses-      ErrorResponse (..)-    , HandlerContents (..)-      -- * Header-    , Header (..)-      -- * Cookie names-    , langKey-      -- * Widgets-    , GWData (..)-    , Location (..)-    , UniqueList (..)-    , Script (..)-    , Stylesheet (..)-    , Title (..)-    , Head (..)-    , Body (..)-    , locationToHtmlUrl-    , runUniqueList-    , toUnique-      -- * Names-    , tokenKey-    ) where--import Text.Hamlet (HtmlUrl, Html)-import Text.Blaze.Html (toHtml)-import Text.Julius (JavascriptUrl)-import Data.Monoid (Monoid (..), Last)-import Data.List (nub)--import Data.Text (Text)--import Data.Typeable (Typeable)-import Control.Exception (Exception)--import qualified Network.HTTP.Types as H-import Data.String (IsString)-import qualified Data.Map as Map-import Data.Text.Lazy.Builder (Builder)-import Web.Cookie (SetCookie (..))-import Data.ByteString (ByteString)-import qualified Network.Wai as W-import Yesod.Content (ChooseRep, ContentType)---- | Responses to indicate some form of an error occurred. These are different--- from 'SpecialResponse' in that they allow for custom error pages.-data ErrorResponse =-      NotFound-    | InternalError Text-    | InvalidArgs [Text]-    | PermissionDenied Text-    | BadMethod H.Method-    deriving (Show, Eq, Typeable)-instance Exception ErrorResponse------- header stuff--- | Headers to be added to a 'Result'.-data Header =-    AddCookie SetCookie-    | DeleteCookie ByteString ByteString-    | Header ByteString ByteString-    deriving (Eq, Show)--langKey :: IsString a => a-langKey = "_LANG"--data Location url = Local url | Remote Text-    deriving (Show, Eq)-locationToHtmlUrl :: Location url -> HtmlUrl url-locationToHtmlUrl (Local url) render = toHtml $ render url []-locationToHtmlUrl (Remote s) _ = toHtml s--newtype UniqueList x = UniqueList ([x] -> [x])-instance Monoid (UniqueList x) where-    mempty = UniqueList id-    UniqueList x `mappend` UniqueList y = UniqueList $ x . y-runUniqueList :: Eq x => UniqueList x -> [x]-runUniqueList (UniqueList x) = nub $ x []-toUnique :: x -> UniqueList x-toUnique = UniqueList . (:)--data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }-    deriving (Show, Eq)-data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }-    deriving (Show, Eq)-newtype Title = Title { unTitle :: Html }--newtype Head url = Head (HtmlUrl url)-    deriving Monoid-newtype Body url = Body (HtmlUrl url)-    deriving Monoid--tokenKey :: IsString a => a-tokenKey = "_TOKEN"--type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder--data GWData a = GWData-    { gwdBody :: !(Body a)-    , gwdTitle :: !(Last Title)-    , gwdScripts :: !(UniqueList (Script a))-    , gwdStylesheets :: !(UniqueList (Stylesheet a))-    , gwdCss :: !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type-    , gwdJavascript :: !(Maybe (JavascriptUrl a))-    , gwdHead :: !(Head a)-    }-instance Monoid (GWData a) where-    mempty = GWData mempty mempty mempty mempty mempty mempty mempty-    mappend (GWData a1 a2 a3 a4 a5 a6 a7)-            (GWData b1 b2 b3 b4 b5 b6 b7) = GWData-        (a1 `mappend` b1)-        (a2 `mappend` b2)-        (a3 `mappend` b3)-        (a4 `mappend` b4)-        (Map.unionWith mappend a5 b5)-        (a6 `mappend` b6)-        (a7 `mappend` b7)--data HandlerContents =-      HCContent H.Status ChooseRep-    | HCError ErrorResponse-    | HCSendFile ContentType FilePath (Maybe W.FilePart)-    | HCRedirect H.Status Text-    | HCCreated Text-    | HCWai W.Response-    deriving Typeable--instance Show HandlerContents where-    show _ = "Cannot show a HandlerContents"-instance Exception HandlerContents
− Yesod/Internal/Cache.hs 
@@ -1,38 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-module Yesod.Internal.Cache-    ( Cache-    , CacheKey-    , mkCacheKey-    , lookup-    , insert-    , delete-    ) where--import Prelude hiding (lookup)-import qualified Data.IntMap as Map-import Language.Haskell.TH.Syntax (Q, Exp, runIO, Exp (LitE), Lit (IntegerL))-import Language.Haskell.TH (appE)-import Data.Unique (hashUnique, newUnique)-import GHC.Exts (Any)-import Unsafe.Coerce (unsafeCoerce)-import Data.Monoid (Monoid)-import Control.Applicative ((<$>))--newtype Cache = Cache (Map.IntMap Any)-    deriving Monoid--newtype CacheKey a = CacheKey Int---- | Generate a new 'CacheKey'. Be sure to give a full type signature.-mkCacheKey :: Q Exp-mkCacheKey = [|CacheKey|] `appE` (LitE . IntegerL . fromIntegral . hashUnique <$> runIO newUnique)--lookup :: CacheKey a -> Cache -> Maybe a-lookup (CacheKey i) (Cache m) = unsafeCoerce <$> Map.lookup i m--insert :: CacheKey a -> a -> Cache -> Cache-insert (CacheKey k) v (Cache m) = Cache (Map.insert k (unsafeCoerce v) m)--delete :: CacheKey a -> Cache -> Cache-delete (CacheKey k) (Cache m) = Cache (Map.delete k m)
− Yesod/Internal/Core.hs 
@@ -1,928 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}--- | The basic typeclass for a Yesod application.-module Yesod.Internal.Core-    ( -- * Type classes-      Yesod (..)-    , YesodDispatch (..)-    , RenderRoute (..)-      -- ** Breadcrumbs-    , YesodBreadcrumbs (..)-    , breadcrumbs-      -- * Utitlities-    , maybeAuthorized-    , widgetToPageContent-      -- * Defaults-    , defaultErrorHandler-      -- * Data types-    , AuthResult (..)-      -- * Sessions-    , SessionBackend (..)-    , defaultClientSessionBackend-    , clientSessionBackend-    , loadClientSession-    , clientSessionBackend2-    , loadClientSession2-    , clientSessionDateCacher-    , BackendSession-      -- * jsLoader-    , ScriptLoadPosition (..)-    , BottomOfHeadAsync-    , loadJsYepnope-      -- * Misc-    , yesodVersion-    , yesodRender-    , resolveApproot-    , Approot (..)-    , FileUpload (..)-    , runFakeHandler-    ) where--import Yesod.Content-import Yesod.Handler hiding (lift, getExpires)-import Control.Monad.Logger (logErrorS)--import Yesod.Routes.Class-import Data.Time (UTCTime, addUTCTime, getCurrentTime)--import Data.Word (Word64)-import Control.Arrow ((***))-import Control.Monad (forM)-import Yesod.Widget-import Yesod.Request-import qualified Network.Wai as W-import Yesod.Internal-import Yesod.Internal.Session-import Yesod.Internal.Request-import qualified Web.ClientSession as CS-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L-import qualified Data.IORef as I-import Data.Monoid-import Text.Hamlet-import Text.Julius-import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString)-import qualified Text.Blaze.Html5 as TBH-import Data.Text.Lazy.Builder (toLazyText)-import Data.Text.Lazy.Encoding (encodeUtf8)-import Data.Maybe (fromMaybe, isJust)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Trans.Resource (runResourceT)-import Web.Cookie (parseCookies)-import qualified Data.Map as Map-import Network.HTTP.Types (encodePath)-import qualified Data.Text as T-import Data.Text (Text)-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Encoding.Error as TEE-import Blaze.ByteString.Builder (Builder, toByteString)-import Blaze.ByteString.Builder.Char.Utf8 (fromText)-import Data.List (foldl')-import qualified Network.HTTP.Types as H-import Web.Cookie (SetCookie (..))-import Language.Haskell.TH.Syntax (Loc (..))-import Text.Blaze (preEscapedToMarkup)-import Data.Aeson (Value (Array, String))-import Data.Aeson.Encode (encode)-import qualified Data.Vector as Vector-import Network.Wai.Middleware.Gzip (GzipSettings, def)-import Network.Wai.Parse (tempFileBackEnd, lbsBackEnd)-import qualified Paths_yesod_core-import Data.Version (showVersion)-import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr)-import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource)-import System.Log.FastLogger.Date (ZonedDate)-import System.IO (stdout)--yesodVersion :: String-yesodVersion = showVersion Paths_yesod_core.version---- | This class is automatically instantiated when you use the template haskell--- mkYesod function. You should never need to deal with it directly.-class YesodDispatch sub master where-    yesodDispatch-        :: Yesod master-        => Logger-        -> master-        -> sub-        -> (Route sub -> Route master)-        -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler-        -> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler-        -> Text -- ^ request method-        -> [Text] -- ^ pieces-        -> Maybe (SessionBackend master)-        -> W.Application--    yesodRunner :: Yesod master-                => Logger-                -> GHandler sub master ChooseRep-                -> master-                -> sub-                -> Maybe (Route sub)-                -> (Route sub -> Route master)-                -> Maybe (SessionBackend master)-                -> W.Application-    yesodRunner = defaultYesodRunner---- | How to determine the root of the application for constructing URLs.------ Note that future versions of Yesod may add new constructors without bumping--- the major version number. As a result, you should /not/ pattern match on--- @Approot@ values.-data Approot master = ApprootRelative -- ^ No application root.-                    | ApprootStatic Text-                    | ApprootMaster (master -> Text)-                    | ApprootRequest (master -> W.Request -> Text)--type ResolvedApproot = Text---- | Define settings for a Yesod applications. All methods have intelligent--- defaults, and therefore no implementation is required.-class RenderRoute a => Yesod a where-    -- | An absolute URL to the root of the application. Do not include-    -- trailing slash.-    ---    -- Default value: 'ApprootRelative'. This is valid under the following-    -- conditions:-    ---    -- * Your application is served from the root of the domain.-    ---    -- * You do not use any features that require absolute URLs, such as Atom-    -- feeds and XML sitemaps.-    ---    -- If this is not true, you should override with a different-    -- implementation.-    approot :: Approot a-    approot = ApprootRelative--    -- | Output error response pages.-    errorHandler :: ErrorResponse -> GHandler sub a ChooseRep-    errorHandler = defaultErrorHandler--    -- | Applies some form of layout to the contents of a page.-    defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml-    defaultLayout w = do-        p <- widgetToPageContent w-        mmsg <- getMessage-        hamletToRepHtml [hamlet|-$newline never-$doctype 5--<html>-    <head>-        <title>#{pageTitle p}-        ^{pageHead p}-    <body>-        $maybe msg <- mmsg-            <p .message>#{msg}-        ^{pageBody p}-|]--    -- | Override the rendering function for a particular URL. One use case for-    -- this is to offload static hosting to a different domain name to avoid-    -- sending cookies.-    urlRenderOverride :: a -> Route a -> Maybe Builder-    urlRenderOverride _ _ = Nothing--    -- | Determine if a request is authorized or not.-    ---    -- Return 'Authorized' if the request is authorized,-    -- 'Unauthorized' a message if unauthorized.-    -- If authentication is required, return 'AuthenticationRequired'.-    isAuthorized :: Route a-                 -> Bool -- ^ is this a write request?-                 -> GHandler s a AuthResult-    isAuthorized _ _ = return Authorized--    -- | Determines whether the current request is a write request. By default,-    -- this assumes you are following RESTful principles, and determines this-    -- from request method. In particular, all except the following request-    -- methods are considered write: GET HEAD OPTIONS TRACE.-    ---    -- This function is used to determine if a request is authorized; see-    -- 'isAuthorized'.-    isWriteRequest :: Route a -> GHandler s a Bool-    isWriteRequest _ = do-        wai <- waiRequest-        return $ W.requestMethod wai `notElem`-            ["GET", "HEAD", "OPTIONS", "TRACE"]--    -- | The default route for authentication.-    ---    -- Used in particular by 'isAuthorized', but library users can do whatever-    -- they want with it.-    authRoute :: a -> Maybe (Route a)-    authRoute _ = Nothing--    -- | A function used to clean up path segments. It returns 'Right' with a-    -- clean path or 'Left' with a new set of pieces the user should be-    -- redirected to. The default implementation enforces:-    ---    -- * No double slashes-    ---    -- * There is no trailing slash.-    ---    -- Note that versions of Yesod prior to 0.7 used a different set of rules-    -- involing trailing slashes.-    cleanPath :: a -> [Text] -> Either [Text] [Text]-    cleanPath _ s =-        if corrected == s-            then Right $ map dropDash s-            else Left corrected-      where-        corrected = filter (not . T.null) s-        dropDash t-            | T.all (== '-') t = T.drop 1 t-            | otherwise = t--    -- | Builds an absolute URL by concatenating the application root with the-    -- pieces of a path and a query string, if any.-    -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'.-    joinPath :: a-             -> T.Text -- ^ application root-             -> [T.Text] -- ^ path pieces-             -> [(T.Text, T.Text)] -- ^ query string-             -> Builder-    joinPath _ ar pieces' qs' =-        fromText ar `mappend` encodePath pieces qs-      where-        pieces = if null pieces' then [""] else map addDash pieces'-        qs = map (TE.encodeUtf8 *** go) qs'-        go "" = Nothing-        go x = Just $ TE.encodeUtf8 x-        addDash t-            | T.all (== '-') t = T.cons '-' t-            | otherwise = t--    -- | This function is used to store some static content to be served as an-    -- external file. The most common case of this is stashing CSS and-    -- JavaScript content in an external file; the "Yesod.Widget" module uses-    -- this feature.-    ---    -- The return value is 'Nothing' if no storing was performed; this is the-    -- default implementation. A 'Just' 'Left' gives the absolute URL of the-    -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is-    -- necessary when you are serving the content outside the context of a-    -- Yesod application, such as via memcached.-    addStaticContent :: Text -- ^ filename extension-                     -> Text -- ^ mime-type-                     -> L.ByteString -- ^ content-                     -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)])))-    addStaticContent _ _ _ = return Nothing--    {- Temporarily disabled until we have a better interface.-    -- | Whether or not to tie a session to a specific IP address. Defaults to-    -- 'False'.-    ---    -- Note: This setting has two known problems: it does not work correctly-    -- when behind a reverse proxy (including load balancers), and it may not-    -- function correctly if the user is behind a proxy.-    sessionIpAddress :: a -> Bool-    sessionIpAddress _ = False-    -}--    -- | The path value to set for cookies. By default, uses \"\/\", meaning-    -- cookies will be sent to every page on the current domain.-    cookiePath :: a -> S8.ByteString-    cookiePath _ = "/"--    -- | The domain value to set for cookies. By default, the-    -- domain is not set, meaning cookies will be sent only to-    -- the current domain.-    cookieDomain :: a -> Maybe S8.ByteString-    cookieDomain _ = Nothing--    -- | Maximum allowed length of the request body, in bytes.-    ---    -- Default: 2 megabytes.-    maximumContentLength :: a -> Maybe (Route a) -> Word64-    maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes--    -- | Returns a @Logger@ to use for log messages.-    ---    -- Default: Sends to stdout and automatically flushes on each write.-    getLogger :: a -> IO Logger-    getLogger _ = mkLogger True stdout--    -- | Send a message to the @Logger@ provided by @getLogger@.-    ---    -- Note: This method is no longer used. Instead, you should override-    -- 'messageLoggerSource'.-    messageLogger :: a-                  -> Logger-                  -> Loc -- ^ position in source code-                  -> LogLevel-                  -> LogStr -- ^ message-                  -> IO ()-    messageLogger a logger loc = messageLoggerSource a logger loc ""--    -- | Send a message to the @Logger@ provided by @getLogger@.-    messageLoggerSource :: a-                        -> Logger-                        -> Loc -- ^ position in source code-                        -> LogSource-                        -> LogLevel-                        -> LogStr -- ^ message-                        -> IO ()-    messageLoggerSource a logger loc source level msg =-        if shouldLog a source level-            then formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger-            else return ()--    -- | The logging level in place for this application. Any messages below-    -- this level will simply be ignored.-    logLevel :: a -> LogLevel-    logLevel _ = LevelInfo--    -- | GZIP settings.-    gzipSettings :: a -> GzipSettings-    gzipSettings _ = def--    -- | Where to Load sripts from. We recommend the default value,-    -- 'BottomOfBody'.  Alternatively use the built in async yepnope loader:-    ---    -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js-    ---    -- Or write your own async js loader: see 'loadJsYepnope'-    jsLoader :: a -> ScriptLoadPosition a-    jsLoader _ = BottomOfBody--    -- | Create a session backend. Returning `Nothing' disables sessions.-    ---    -- Default: Uses clientsession with a 2 hour timeout.-    makeSessionBackend :: a -> IO (Maybe (SessionBackend a))-    makeSessionBackend _ = fmap Just defaultClientSessionBackend--    -- | How to store uploaded files.-    ---    -- Default: When the request body is greater than 50kb, store in a temp-    -- file. Otherwise, store in memory.-    fileUpload :: a-               -> Word64 -- ^ request body size-               -> FileUpload-    fileUpload _ size-        | size > 50000 = FileUploadDisk tempFileBackEnd-        | otherwise = FileUploadMemory lbsBackEnd--    -- | Should we log the given log source/level combination.-    ---    -- Default: Logs everything at or above 'logLevel'-    shouldLog :: a -> LogSource -> LogLevel -> Bool-    shouldLog a _ level = level >= logLevel a--    -- | A Yesod middleware, which will wrap every handler function. This-    -- allows you to run code before and after a normal handler.-    ---    -- Default: Adds the response header \"Vary: Accept, Accept-Language\".-    ---    -- Since: 1.1.6-    yesodMiddleware :: GHandler sub a res -> GHandler sub a res-    yesodMiddleware handler = do-        setHeader "Vary" "Accept, Accept-Language"-        handler--{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-}--formatLogMessage :: IO ZonedDate-                 -> Loc-                 -> LogSource-                 -> LogLevel-                 -> LogStr -- ^ message-                 -> IO [LogStr]-formatLogMessage getdate loc src level msg = do-    now <- getdate-    return-        [ LB now-        , LB " ["-        , LS $-            case level of-                LevelOther t -> T.unpack t-                _ -> drop 5 $ show level-        , LS $-            if T.null src-                then ""-                else "#" ++ T.unpack src-        , LB "] "-        , msg-        , LB " @("-        , LS $ fileLocationToString loc-        , LB ")\n"-        ]---- taken from file-location package--- turn the TH Loc loaction information into a human readable string--- leaving out the loc_end parameter-fileLocationToString :: Loc -> String-fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++-  ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)-  where-    line = show . fst . loc_start-    char = show . snd . loc_start--defaultYesodRunner :: Yesod master-                   => Logger-                   -> GHandler sub master ChooseRep-                   -> master-                   -> sub-                   -> Maybe (Route sub)-                   -> (Route sub -> Route master)-                   -> Maybe (SessionBackend master)-                   -> W.Application-defaultYesodRunner logger handler' master sub murl toMasterRoute msb req-  | maxLen < len = return tooLargeResponse-  | otherwise = do-    let dontSaveSession _ _ = return []-    now <- liftIO getCurrentTime -- FIXME remove in next major version bump-    (session, saveSession) <- liftIO $ do-        maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb-    rr <- liftIO $ parseWaiRequest req session (isJust msb) len maxLen-    let h = {-# SCC "h" #-} do-          case murl of-            Nothing -> handler-            Just url -> do-                isWrite <- isWriteRequest $ toMasterRoute url-                ar <- isAuthorized (toMasterRoute url) isWrite-                case ar of-                    Authorized -> return ()-                    AuthenticationRequired ->-                        case authRoute master of-                            Nothing ->-                                permissionDenied "Authentication required"-                            Just url' -> do-                                setUltDestCurrent-                                redirect url'-                    Unauthorized s' -> permissionDenied s'-                handler-    let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session-    let ra = resolveApproot master req-    let log' = messageLoggerSource master logger-    yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute-        (yesodRender master ra) errorHandler rr murl sessionMap h-    extraHeaders <- case yar of-        (YARPlain _ _ ct _ newSess) -> do-            let nsToken = Map.toList $ maybe-                    newSess-                    (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess)-                    (reqToken rr)-            sessionHeaders <- liftIO (saveSession nsToken now)-            return $ ("Content-Type", ct) : map headerToPair sessionHeaders-        _ -> return []-    return $ yarToResponse yar extraHeaders-  where-    maxLen = maximumContentLength master $ fmap toMasterRoute murl-    len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay-    readMay s =-        case reads $ S8.unpack s of-            [] -> Nothing-            (x, _):_ -> Just x-    handler = yesodMiddleware handler'--data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text-    deriving (Eq, Show, Read)---- | A type-safe, concise method of creating breadcrumbs for pages. For each--- resource, you declare the title of the page and the parent resource (if--- present).-class YesodBreadcrumbs y where-    -- | Returns the title and the parent resource, if available. If you return-    -- a 'Nothing', then this is considered a top-level page.-    breadcrumb :: Route y -> GHandler sub y (Text , Maybe (Route y))---- | Gets the title of the current page and the hierarchy of parent pages,--- along with their respective titles.-breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, Text)])-breadcrumbs = do-    x' <- getCurrentRoute-    tm <- getRouteToMaster-    let x = fmap tm x'-    case x of-        Nothing -> return ("Not found", [])-        Just y -> do-            (title, next) <- breadcrumb y-            z <- go [] next-            return (title, z)-  where-    go back Nothing = return back-    go back (Just this) = do-        (title, next) <- breadcrumb this-        go ((this, title) : back) next--applyLayout' :: Yesod master-             => Html -- ^ title-             -> HtmlUrl (Route master) -- ^ body-             -> GHandler sub master ChooseRep-applyLayout' title body = fmap chooseRep $ defaultLayout $ do-    setTitle title-    toWidget body---- | The default error handler for 'errorHandler'.-defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep-defaultErrorHandler NotFound = do-    r <- waiRequest-    let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r-    applyLayout' "Not Found"-        [hamlet|-$newline never-<h1>Not Found-<p>#{path'}-|]-defaultErrorHandler (PermissionDenied msg) =-    applyLayout' "Permission Denied"-        [hamlet|-$newline never-<h1>Permission denied-<p>#{msg}-|]-defaultErrorHandler (InvalidArgs ia) =-    applyLayout' "Invalid Arguments"-        [hamlet|-$newline never-<h1>Invalid Arguments-<ul>-    $forall msg <- ia-        <li>#{msg}-|]-defaultErrorHandler (InternalError e) = do-    $logErrorS "yesod-core" e-    applyLayout' "Internal Server Error"-        [hamlet|-$newline never-<h1>Internal Server Error-<pre>#{e}-|]-defaultErrorHandler (BadMethod m) =-    applyLayout' "Bad Method"-        [hamlet|-$newline never-<h1>Method Not Supported-<p>Method <code>#{S8.unpack m}</code> not supported-|]---- | Return the same URL if the user is authorized to see it.------ Built on top of 'isAuthorized'. This is useful for building page that only--- contain links to pages the user is allowed to see.-maybeAuthorized :: Yesod a-                => Route a-                -> Bool -- ^ is this a write request?-                -> GHandler s a (Maybe (Route a))-maybeAuthorized r isWrite = do-    x <- isAuthorized r isWrite-    return $ if x == Authorized then Just r else Nothing--jsToHtml :: Javascript -> Html-jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b--jelper :: JavascriptUrl url -> HtmlUrl url-jelper = fmap jsToHtml---- | Convert a widget to a 'PageContent'.-widgetToPageContent :: (Eq (Route master), Yesod master)-                    => GWidget sub master ()-                    -> GHandler sub master (PageContent (Route master))-widgetToPageContent w = do-    master <- getYesod-    ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w-    let title = maybe mempty unTitle mTitle-        scripts = runUniqueList scripts'-        stylesheets = runUniqueList stylesheets'--    render <- getUrlRenderParams-    let renderLoc x =-            case x of-                Nothing -> Nothing-                Just (Left s) -> Just s-                Just (Right (u, p)) -> Just $ render u p-    css <- forM (Map.toList style) $ \(mmedia, content) -> do-        let rendered = toLazyText $ content render-        x <- addStaticContent "css" "text/css; charset=utf-8"-           $ encodeUtf8 rendered-        return (mmedia,-            case x of-                Nothing -> Left $ preEscapedToMarkup rendered-                Just y -> Right $ either id (uncurry render) y)-    jsLoc <--        case jscript of-            Nothing -> return Nothing-            Just s -> do-                x <- addStaticContent "js" "text/javascript; charset=utf-8"-                   $ encodeUtf8 $ renderJavascriptUrl render s-                return $ renderLoc x--    -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing-    -- the asynchronous loader means your page doesn't have to wait for all the js to load-    let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc-        regularScriptLoad = [hamlet|-$newline never-$forall s <- scripts-    ^{mkScriptTag s}-$maybe j <- jscript-    $maybe s <- jsLoc-        <script src="#{s}">-    $nothing-        <script>^{jelper j}-|]--        headAll = [hamlet|-$newline never-\^{head'}-$forall s <- stylesheets-    ^{mkLinkTag s}-$forall s <- css-    $maybe t <- right $ snd s-        $maybe media <- fst s-            <link rel=stylesheet media=#{media} href=#{t}>-        $nothing-            <link rel=stylesheet href=#{t}>-    $maybe content <- left $ snd s-        $maybe media <- fst s-            <style media=#{media}>#{content}-        $nothing-            <style>#{content}-$case jsLoader master-  $of BottomOfBody-  $of BottomOfHeadAsync asyncJsLoader-      ^{asyncJsLoader asyncScripts mcomplete}-  $of BottomOfHeadBlocking-      ^{regularScriptLoad}-|]-    let bodyScript = [hamlet|-$newline never-^{body}-^{regularScriptLoad}-|]--    return $ PageContent title headAll (case jsLoader master of-      BottomOfBody -> bodyScript-      _ -> body)-  where-    renderLoc' render' (Local url) = render' url []-    renderLoc' _ (Remote s) = s--    addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)-    mkScriptTag (Script loc attrs) render' =-        foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()-    mkLinkTag (Stylesheet loc attrs) render' =-        foldl' addAttr TBH.link-            ( ("rel", "stylesheet")-            : ("href", renderLoc' render' loc)-            : attrs-            )--data ScriptLoadPosition master-    = BottomOfBody-    | BottomOfHeadBlocking-    | BottomOfHeadAsync (BottomOfHeadAsync master)--type BottomOfHeadAsync master-       = [Text] -- ^ urls to load asynchronously-      -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion-      -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>--left :: Either a b -> Maybe a-left (Left x) = Just x-left _ = Nothing--right :: Either a b -> Maybe b-right (Right x) = Just x-right _ = Nothing--jsonArray :: [Text] -> Html-jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String---- | For use with setting 'jsLoader' to 'BottomOfHeadAsync'-loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master))-loadJsYepnope eyn scripts mcomplete =-  [hamlet|-$newline never-    $maybe yn <- left eyn-        <script src=#{yn}>-    $maybe yn <- right eyn-        <script src=@{yn}>-    $maybe complete <- mcomplete-        <script>yepnope({load:#{jsonArray scripts},complete:function(){^{complete}}});-    $nothing-        <script>yepnope({load:#{jsonArray scripts}});-|]--asyncHelper :: (url -> [x] -> Text)-         -> [Script (url)]-         -> Maybe (JavascriptUrl (url))-         -> Maybe Text-         -> (Maybe (HtmlUrl url), [Text])-asyncHelper render scripts jscript jsLoc =-    (mcomplete, scripts'')-  where-    scripts' = map goScript scripts-    scripts'' =-        case jsLoc of-            Just s -> scripts' ++ [s]-            Nothing -> scripts'-    goScript (Script (Local url) _) = render url []-    goScript (Script (Remote s) _) = s-    mcomplete =-        case jsLoc of-            Just{} -> Nothing-            Nothing ->-                case jscript of-                    Nothing -> Nothing-                    Just j -> Just $ jelper j--yesodRender :: Yesod y-            => y-            -> ResolvedApproot-            -> Route y-            -> [(Text, Text)] -- ^ url query string-            -> Text-yesodRender y ar url params =-    TE.decodeUtf8 $ toByteString $-    fromMaybe-        (joinPath y ar ps-          $ params ++ params')-        (urlRenderOverride y url)-  where-    (ps, params') = renderRoute url--resolveApproot :: Yesod master => master -> W.Request -> ResolvedApproot-resolveApproot master req =-    case approot of-        ApprootRelative -> ""-        ApprootStatic t -> t-        ApprootMaster f -> f master-        ApprootRequest f -> f master req--defaultClientSessionBackend :: Yesod master => IO (SessionBackend master)-defaultClientSessionBackend = do-  key <- CS.getKey CS.defaultKeyFile-  let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes-  (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout-  return $ clientSessionBackend2 key getCachedDate---clientSessionBackend :: Yesod master-                     => CS.Key  -- ^ The encryption key-                     -> Int -- ^ Inactive session valitity in minutes-                     -> SessionBackend master-clientSessionBackend key timeout = SessionBackend-    { sbLoadSession = loadClientSession key timeout "_SESSION"-    }-{-# DEPRECATED clientSessionBackend "Please use clientSessionBackend2, which is more efficient." #-}--loadClientSession :: Yesod master-                  => CS.Key-                  -> Int -- ^ timeout-                  -> S8.ByteString -- ^ session name-                  -> master-                  -> W.Request-                  -> UTCTime-                  -> IO (BackendSession, SaveSession)-loadClientSession key timeout sessionName master req now = return (sess, save)-  where-    sess = fromMaybe [] $ do-      raw <- lookup "Cookie" $ W.requestHeaders req-      val <- lookup sessionName $ parseCookies raw-      let host = "" -- fixme, properly lock sessions to client address-      decodeClientSessionOld key now host val-    save sess' now' = do-      -- We should never cache the IV!  Be careful!-      iv <- liftIO CS.randomIV-      return [AddCookie def-          { setCookieName = sessionName-          , setCookieValue = sessionVal iv-          , setCookiePath = Just (cookiePath master)-          , setCookieExpires = Just expires-          , setCookieDomain = cookieDomain master-          , setCookieHttpOnly = True-          }]-        where-          host = "" -- fixme, properly lock sessions to client address-          expires = fromIntegral (timeout * 60) `addUTCTime` now'-          sessionVal iv = encodeClientSessionOld key iv expires host sess'-{-# DEPRECATED loadClientSession "Please use loadClientSession2, which is more efficient." #-}--clientSessionBackend2 :: Yesod master-                     => CS.Key  -- ^ The encryption key-                     -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'-                     -> SessionBackend master-clientSessionBackend2 key getCachedDate =-  SessionBackend {-    sbLoadSession = \master req -> const $ loadClientSession2 key getCachedDate "_SESSION" master req-  }--loadClientSession2 :: Yesod master-                  => CS.Key-                  -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'-                  -> S8.ByteString -- ^ session name-                  -> master-                  -> W.Request-                  -> IO (BackendSession, SaveSession)-loadClientSession2 key getCachedDate sessionName master req = load-  where-    load = do-      date <- getCachedDate-      return (sess date, save date)-    sess date = fromMaybe [] $ do-      raw <- lookup "Cookie" $ W.requestHeaders req-      val <- lookup sessionName $ parseCookies raw-      let host = "" -- fixme, properly lock sessions to client address-      decodeClientSession key date host val-    save date sess' _ = do-      -- We should never cache the IV!  Be careful!-      iv <- liftIO CS.randomIV-      return [AddCookie def-          { setCookieName = sessionName-          , setCookieValue = encodeClientSession key iv date host sess'-          , setCookiePath = Just (cookiePath master)-          , setCookieExpires = Just (csdcExpires date)-          , setCookieDomain = cookieDomain master-          , setCookieHttpOnly = True-          }]-        where-          host = "" -- fixme, properly lock sessions to client address----- | Run a 'GHandler' completely outside of Yesod.  This--- function comes with many caveats and you shouldn't use it--- unless you fully understand what it's doing and how it works.------ As of now, there's only one reason to use this function at--- all: in order to run unit tests of functions inside 'GHandler'--- but that aren't easily testable with a full HTTP request.--- Even so, it's better to use @wai-test@ or @yesod-test@ instead--- of using this function.------ This function will create a fake HTTP request (both @wai@'s--- 'W.Request' and @yesod@'s 'Request') and feed it to the--- @GHandler@.  The only useful information the @GHandler@ may--- get from the request is the session map, which you must supply--- as argument to @runFakeHandler@.  All other fields contain--- fake information, which means that they can be accessed but--- won't have any useful information.  The response of the--- @GHandler@ is completely ignored, including changes to the--- session, cookies or headers.  We only return you the--- @GHandler@'s return value.-runFakeHandler :: (Yesod master, MonadIO m) =>-                  SessionMap-               -> (master -> Logger)-               -> master-               -> GHandler master master a-               -> m (Either ErrorResponse a)-runFakeHandler fakeSessionMap logger master handler = liftIO $ do-  ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")-  let handler' = do liftIO . I.writeIORef ret . Right =<< handler-                    return ()-  let YesodApp yapp =-        runHandler-          handler'-          (yesodRender master $ resolveApproot master fakeWaiRequest)-          Nothing-          id-          master-          master-          (fileUpload master)-          (messageLoggerSource master $ logger master)-      errHandler err =-        YesodApp $ \_ _ _ session -> do-          liftIO $ I.writeIORef ret (Left err)-          return $ YARPlain-                     H.status500-                     []-                     typePlain-                     (toContent ("runFakeHandler: errHandler" :: S8.ByteString))-                     session-      fakeWaiRequest =-        W.Request-          { W.requestMethod  = "POST"-          , W.httpVersion    = H.http11-          , W.rawPathInfo    = "/runFakeHandler/pathInfo"-          , W.rawQueryString = ""-          , W.serverName     = "runFakeHandler-serverName"-          , W.serverPort     = 80-          , W.requestHeaders = []-          , W.isSecure       = False-          , W.remoteHost     = error "runFakeHandler-remoteHost"-          , W.pathInfo       = ["runFakeHandler", "pathInfo"]-          , W.queryString    = []-          , W.requestBody    = mempty-          , W.vault          = mempty-#if MIN_VERSION_wai(1, 4, 0)-          , W.requestBodyLength = W.KnownLength 0-#endif-          }-      fakeRequest =-        Request-          { reqGetParams  = []-          , reqCookies    = []-          , reqWaiRequest = fakeWaiRequest-          , reqLangs      = []-          , reqToken      = Just "NaN" -- not a nonce =)-          , reqBodySize   = 0-          }-      fakeContentType = []-  _ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap-  I.readIORef ret-{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
− Yesod/Internal/Request.hs 
@@ -1,183 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Yesod.Internal.Request-    ( parseWaiRequest-    , Request (..)-    , RequestBodyContents-    , FileInfo-    , fileName-    , fileContentType-    , fileSource-    , fileMove-    , mkFileInfoLBS-    , mkFileInfoFile-    , mkFileInfoSource-    , FileUpload (..)-    , tooLargeResponse-    -- The below are exported for testing.-    , randomString-    , parseWaiRequest'-    ) where--import Control.Applicative ((<$>))-import Control.Arrow (second)-import qualified Network.Wai.Parse as NWP-import Yesod.Internal-import qualified Network.Wai as W-import System.Random (RandomGen, newStdGen, randomRs)-import Web.Cookie (parseCookiesText)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8-import Data.Text (Text, pack)-import Network.HTTP.Types (queryToQueryText, Status (Status))-import Control.Monad (join)-import Data.Maybe (fromMaybe, catMaybes)-import qualified Data.ByteString.Lazy as L-import qualified Data.Set as Set-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Data.Conduit-import Data.Conduit.List (sourceList)-import Data.Conduit.Binary (sourceFile, sinkFile)-import Data.Word (Word64)-import Control.Monad.IO.Class (liftIO)-import Control.Exception (throwIO)---- | The parsed request information.-data Request = Request-    { reqGetParams :: [(Text, Text)]-    , reqCookies :: [(Text, Text)]-    , reqWaiRequest :: W.Request-      -- | Languages which the client supports.-    , reqLangs :: [Text]-      -- | A random, session-specific token used to prevent CSRF attacks.-    , reqToken :: Maybe Text-      -- | Size of the request body.-      ---      -- Note: in the presence of chunked request bodies, this value will be 0,-      -- even though data is available.-    , reqBodySize :: Word64 -- FIXME Consider in the future using a Maybe to represent chunked bodies-    }--parseWaiRequest :: W.Request-                -> [(Text, ByteString)] -- ^ session-                -> Bool-                -> Word64 -- ^ actual length... might be meaningless, see 'reqBodySize'-                -> Word64 -- ^ maximum allowed body size-                -> IO Request-parseWaiRequest env session' useToken bodySize maxBodySize =-    parseWaiRequest' env session' useToken bodySize maxBodySize <$> newStdGen---- | Impose a limit on the size of the request body.-limitRequestBody :: Word64 -> W.Request -> W.Request-limitRequestBody maxLen req =-    req { W.requestBody = W.requestBody req $= limit maxLen }-  where-    tooLarge = liftIO $ throwIO $ HCWai tooLargeResponse--    limit 0 = tooLarge-    limit remaining =-        await >>= maybe (return ()) go-      where-        go bs = do-            let len = fromIntegral $ S8.length bs-            if len > remaining-                then tooLarge-                else do-                    yield bs-                    limit $ remaining - len--tooLargeResponse :: W.Response-tooLargeResponse = W.responseLBS-    (Status 413 "Too Large")-    [("Content-Type", "text/plain")]-    "Request body too large to be processed."--parseWaiRequest' :: RandomGen g-                 => W.Request-                 -> [(Text, ByteString)] -- ^ session-                 -> Bool-                 -> Word64-                 -> Word64 -- ^ max body size-                 -> g-                 -> Request-parseWaiRequest' env session' useToken bodySize maxBodySize gen =-    Request gets'' cookies' (limitRequestBody maxBodySize env) langs'' token bodySize-  where-    gets' = queryToQueryText $ W.queryString env-    gets'' = map (second $ fromMaybe "") gets'-    reqCookie = lookup "Cookie" $ W.requestHeaders env-    cookies' = maybe [] parseCookiesText reqCookie-    acceptLang = lookup "Accept-Language" $ W.requestHeaders env-    langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang--    lookupText k = fmap (decodeUtf8With lenientDecode) . lookup k--    -- The language preferences are prioritized as follows:-    langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG-                       , lookup langKey cookies'     -- Cookie _LANG-                       , lookupText langKey session' -- Session _LANG-                       ] ++ langs                    -- Accept-Language(s)--    -- Github issue #195. We want to add an extra two-letter version of any-    -- language in the list.-    langs'' = addTwoLetters (id, Set.empty) langs'--    -- If sessions are disabled tokens should not be used (any-    -- tokenKey present in the session is ignored). If sessions-    -- are enabled and a session has no tokenKey a new one is-    -- generated.-    token = if not useToken-              then Nothing-              else Just $ maybe-                            (pack $ randomString 10 gen)-                            (decodeUtf8With lenientDecode)-                            (lookup tokenKey session')--addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]-addTwoLetters (toAdd, exist) [] =-    filter (flip Set.notMember exist) $ toAdd []-addTwoLetters (toAdd, exist) (l:ls) =-    l : addTwoLetters (toAdd', exist') ls-  where-    (toAdd', exist')-        | T.length l > 2 = (toAdd . (T.take 2 l:), exist)-        | otherwise = (toAdd, Set.insert l exist)---- | Generate a random String of alphanumerical characters--- (a-z, A-Z, and 0-9) of the given length using the given--- random number generator.-randomString :: RandomGen g => Int -> g -> String-randomString len = take len . map toChar . randomRs (0, 61)-  where-    toChar i-        | i < 26 = toEnum $ i + fromEnum 'A'-        | i < 52 = toEnum $ i + fromEnum 'a' - 26-        | otherwise = toEnum $ i + fromEnum '0' - 52---- | A tuple containing both the POST parameters and submitted files.-type RequestBodyContents =-    ( [(Text, Text)]-    , [(Text, FileInfo)]-    )--data FileInfo = FileInfo-    { fileName :: Text-    , fileContentType :: Text-    , fileSource :: Source (ResourceT IO) ByteString-    , fileMove :: FilePath -> IO ()-    }--mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo-mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs)--mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo-mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)--mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo-mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)--data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString)-                | FileUploadDisk (NWP.BackEnd FilePath)-                | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString))
− Yesod/Internal/Session.hs 
@@ -1,161 +0,0 @@-module Yesod.Internal.Session-    ( encodeClientSession-    , encodeClientSessionOld-    , decodeClientSession-    , decodeClientSessionOld-    , clientSessionDateCacher-    , ClientSessionDateCache(..)-    , BackendSession-    , SaveSession-    , SaveSessionOld-    , SessionBackend(..)-    ) where--import Yesod.Internal (Header(..))-import qualified Web.ClientSession as CS-import Data.Int (Int64)-import Data.Serialize-import Data.Time-import Data.ByteString (ByteString)-import Control.Concurrent (forkIO, killThread, threadDelay)-import Control.Monad (forever, guard)-import Data.Text (Text, pack, unpack)-import Control.Arrow (first)-import Control.Applicative ((<$>))--import qualified Data.ByteString.Char8 as S8-import qualified Data.IORef as I-import qualified Network.Wai as W--type BackendSession = [(Text, S8.ByteString)]--type SaveSession = BackendSession    -- ^ The session contents after running the handler-                -> UTCTime -- FIXME remove this in the next major version bump-                -> IO [Header]--type SaveSessionOld = BackendSession    -- ^ The session contents after running the handler-                -> UTCTime-                -> IO [Header]--newtype SessionBackend master = SessionBackend-    { sbLoadSession :: master-                    -> W.Request-                    -> UTCTime -- FIXME remove this in the next major version bump-                    -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session-    }--encodeClientSession :: CS.Key-                    -> CS.IV-                    -> ClientSessionDateCache  -- ^ expire time-                    -> ByteString -- ^ remote host-                    -> [(Text, ByteString)] -- ^ session-                    -> ByteString -- ^ cookie value-encodeClientSession key iv date rhost session' =-    CS.encrypt key iv $ encode $ SessionCookie expires rhost session'-      where expires = Right (csdcExpiresSerialized date)--decodeClientSession :: CS.Key-                    -> ClientSessionDateCache  -- ^ current time-                    -> ByteString -- ^ remote host field-                    -> ByteString -- ^ cookie value-                    -> Maybe [(Text, ByteString)]-decodeClientSession key date rhost encrypted = do-    decrypted <- CS.decrypt key encrypted-    SessionCookie (Left expire) rhost' session' <--        either (const Nothing) Just $ decode decrypted-    guard $ expire > csdcNow date-    guard $ rhost' == rhost-    return session'--data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)]-    deriving (Show, Read)-instance Serialize SessionCookie where-    put (SessionCookie a b c) = do-        either putTime putByteString a-        put b-        put (map (first unpack) c)-    get = do-        a <- getTime-        b <- get-        c <- map (first pack) <$> get-        return $ SessionCookie (Left a) b c------------------------------------------------------------------------------ Mostly copied from Kazu's date-cache, but with modifications--- that better suit our needs.------ The cached date is updated every 10s, we don't need second--- resolution for session expiration times.--data ClientSessionDateCache =-  ClientSessionDateCache {-    csdcNow               :: !UTCTime-  , csdcExpires           :: !UTCTime-  , csdcExpiresSerialized :: !ByteString-  } deriving (Eq, Show)--clientSessionDateCacher ::-     NominalDiffTime -- ^ Inactive session valitity.-  -> IO (IO ClientSessionDateCache, IO ())-clientSessionDateCacher validity = do-    ref <- getUpdated >>= I.newIORef-    tid <- forkIO $ forever (doUpdate ref)-    return $! (I.readIORef ref, killThread tid)-  where-    getUpdated = do-      now <- getCurrentTime-      let expires  = validity `addUTCTime` now-          expiresS = runPut (putTime expires)-      return $! ClientSessionDateCache now expires expiresS-    doUpdate ref = do-      threadDelay 10000000 -- 10s-      I.writeIORef ref =<< getUpdated----------------------------------------------------------------------------putTime :: Putter UTCTime-putTime (UTCTime d t) =-  let d' = fromInteger  $ toModifiedJulianDay d-      t' = fromIntegral $ fromEnum (t / diffTimeScale)-  in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')--getTime :: Get UTCTime-getTime = do-  val <- get-  let (d, t) = val `divMod` posixDayLength_int64-      d' = ModifiedJulianDay $! fromIntegral d-      t' = fromIntegral t-  d' `seq` t' `seq` return (UTCTime d' t')--posixDayLength_int64 :: Int64-posixDayLength_int64 = 86400--diffTimeScale :: DiffTime-diffTimeScale = 1e12--encodeClientSessionOld :: CS.Key-                    -> CS.IV-                    -> UTCTime -- ^ expire time-                    -> ByteString -- ^ remote host-                    -> [(Text, ByteString)] -- ^ session-                    -> ByteString -- ^ cookie value-encodeClientSessionOld key iv expire rhost session' =-    CS.encrypt key iv $ encode $ SessionCookie (Left expire) rhost session'--decodeClientSessionOld :: CS.Key-                    -> UTCTime -- ^ current time-                    -> ByteString -- ^ remote host field-                    -> ByteString -- ^ cookie value-                    -> Maybe [(Text, ByteString)]-decodeClientSessionOld key now rhost encrypted = do-    decrypted <- CS.decrypt key encrypted-    SessionCookie (Left expire) rhost' session' <--        either (const Nothing) Just $ decode decrypted-    guard $ expire > now-    guard $ rhost' == rhost-    return session'
− Yesod/Internal/TestApi.hs 
@@ -1,11 +0,0 @@------ | WARNING: This module exposes internal interfaces solely for the--- purpose of facilitating cabal-driven testing of said interfaces.--- This module is NOT part of the public Yesod API and should NOT be--- imported by library users.----module Yesod.Internal.TestApi-  ( randomString, parseWaiRequest'-  ) where--import Yesod.Internal.Request (randomString, parseWaiRequest')
− Yesod/Message.hs 
@@ -1,6 +0,0 @@--- | This module has moved to "Text.Shakespeare.I18N"-module Yesod.Message-    ( module Text.Shakespeare.I18N-    ) where--import Text.Shakespeare.I18N
− Yesod/Request.hs 
@@ -1,108 +0,0 @@---------------------------------------------------------------- Module        : Yesod.Request--- Copyright     : Michael Snoyman--- License       : BSD3------ Maintainer    : Michael Snoyman <michael@snoyman.com>--- Stability     : Stable--- Portability   : portable------ | Provides a parsed version of the raw 'W.Request' data.--------------------------------------------------------------module Yesod.Request-    (-      -- * Request datatype-      RequestBodyContents-    , Request (..)-    , FileInfo-    , fileName-    , fileContentType-    , fileSource-    , fileMove-      -- * Convenience functions-    , languages-      -- * Lookup parameters-    , lookupGetParam-    , lookupPostParam-    , lookupCookie-    , lookupFile-      -- ** Multi-lookup-    , lookupGetParams-    , lookupPostParams-    , lookupCookies-    , lookupFiles-    ) where--import Yesod.Internal.Request-import Yesod.Handler-import Control.Monad (liftM)-import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r-import Data.Maybe (listToMaybe)-import Data.Text (Text)---- | Get the list of supported languages supplied by the user.------ Languages are determined based on the following three (in descending order--- of preference):------ * The _LANG get parameter.------ * The _LANG cookie.------ * The _LANG user session variable.------ * Accept-Language HTTP header.------ Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates.--- If a matching language is not found the default language will be used.------ This is handled by parseWaiRequest (not exposed).-languages :: GHandler s m [Text]-languages = reqLangs `liftM` getRequest--lookup' :: Eq a => a -> [(a, b)] -> [b]-lookup' a = map snd . filter (\x -> a == fst x)---- | Lookup for GET parameters.-lookupGetParams :: Text -> GHandler s m [Text]-lookupGetParams pn = do-    rr <- getRequest-    return $ lookup' pn $ reqGetParams rr---- | Lookup for GET parameters.-lookupGetParam :: Text -> GHandler s m (Maybe Text)-lookupGetParam = liftM listToMaybe . lookupGetParams---- | Lookup for POST parameters.-lookupPostParams :: Text -> GHandler s m [Text]-lookupPostParams pn = do-    (pp, _) <- runRequestBody-    return $ lookup' pn pp--lookupPostParam :: Text-                -> GHandler s m (Maybe Text)-lookupPostParam = liftM listToMaybe . lookupPostParams---- | Lookup for POSTed files.-lookupFile :: Text-           -> GHandler s m (Maybe FileInfo)-lookupFile = liftM listToMaybe . lookupFiles---- | Lookup for POSTed files.-lookupFiles :: Text-            -> GHandler s m [FileInfo]-lookupFiles pn = do-    (_, files) <- runRequestBody-    return $ lookup' pn files---- | Lookup for cookie data.-lookupCookie :: Text -> GHandler s m (Maybe Text)-lookupCookie = liftM listToMaybe . lookupCookies---- | Lookup for cookie data.-lookupCookies :: Text -> GHandler s m [Text]-lookupCookies pn = do-    rr <- getRequest-    return $ lookup' pn $ reqCookies rr
− Yesod/Widget.hs 
@@ -1,369 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-}--- FIXME Should we remove the older names here (addJulius, etc)?---- | Widgets combine HTML with JS and CSS dependencies with a unique identifier--- generator, allowing you to create truly modular HTML components.-module Yesod.Widget-    ( -- * Datatype-      GWidget-    , PageContent (..)-      -- * Special Hamlet quasiquoter/TH for Widgets-    , whamlet-    , whamletFile-    , ihamletToRepHtml-      -- * Convert to Widget-    , ToWidget (..)-    , ToWidgetHead (..)-    , ToWidgetBody (..)-      -- * Creating-      -- ** Head of page-    , setTitle-    , setTitleI-    , addHamletHead-    , addHtmlHead-      -- ** Body-    , addHamlet-    , addHtml-    , addWidget-    , addSubWidget-      -- ** CSS-    , addCassius-    , addCassiusMedia-    , addLucius-    , addLuciusMedia-    , addStylesheet-    , addStylesheetAttrs-    , addStylesheetRemote-    , addStylesheetRemoteAttrs-    , addStylesheetEither-    , CssBuilder (..)-      -- ** Javascript-    , addJulius-    , addJuliusBody-    , addScript-    , addScriptAttrs-    , addScriptRemote-    , addScriptRemoteAttrs-    , addScriptEither-      -- * Internal-    , unGWidget-    , whamletFileWithSettings-    ) where--import Data.Monoid-import qualified Text.Blaze.Html5 as H-import Text.Hamlet-import Text.Cassius-import Text.Julius-import Yesod.Routes.Class-import Yesod.Handler-    ( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod-    , getMessageRender, getUrlRenderParams, MonadLift (..)-    )-import Yesod.Message (RenderMessage)-import Yesod.Content (RepHtml (..), toContent)-import Control.Applicative (Applicative (..), (<$>))-import Control.Monad.IO.Class (MonadIO (liftIO))-import Yesod.Internal-import Control.Monad (liftM)-import Data.Text (Text)-import qualified Data.Map as Map-import Language.Haskell.TH.Quote (QuasiQuoter)-import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)--import Control.Monad.Trans.Control (MonadBaseControl (..))-import Control.Exception (throwIO)-import qualified Text.Hamlet as NP-import Data.Text.Lazy.Builder (fromLazyText, Builder)-import Text.Blaze.Html (toHtml, preEscapedToMarkup)-import qualified Data.Text.Lazy as TL-import Control.Monad.Base (MonadBase (liftBase))-import Control.Arrow (first)-import Control.Monad.Trans.Resource--import Control.Monad.Logger--preEscapedLazyText :: TL.Text -> Html-preEscapedLazyText = preEscapedToMarkup---- | A generic widget, allowing specification of both the subsite and master--- site datatypes. While this is simply a @WriterT@, we define a newtype for--- better error messages.-newtype GWidget sub master a = GWidget-    { unGWidget :: GHandler sub master (a, GWData (Route master))-    }--instance (a ~ ()) => Monoid (GWidget sub master a) where-    mempty = return ()-    mappend x y = x >> y--addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a-addSubWidget sub (GWidget w) = do-    master <- lift getYesod-    let sr = fromSubRoute sub master-    (a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing w-    tell w'-    return a--class ToWidget sub master a where-    toWidget :: a -> GWidget sub master ()--type RY master = Route master -> [(Text, Text)] -> Text---- | Newtype wrapper allowing injection of arbitrary content into CSS.------ Usage:------ > toWidget $ CssBuilder "p { color: red }"------ Since: 1.1.3-newtype CssBuilder = CssBuilder { unCssBuilder :: Builder }--instance render ~ RY master => ToWidget sub master (render -> Html) where-    toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty-instance render ~ RY master => ToWidget sub master (render -> Css) where-    toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x-instance render ~ RY master => ToWidget sub master (render -> CssBuilder) where-    toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty-instance render ~ RY master => ToWidget sub master (render -> Javascript) where-    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty-instance (sub' ~ sub, master' ~ master) => ToWidget sub' master' (GWidget sub master ()) where-    toWidget = id-instance ToWidget sub master Html where-    toWidget = toWidget . const--class ToWidgetBody sub master a where-    toWidgetBody :: a -> GWidget sub master ()--instance render ~ RY master => ToWidgetBody sub master (render -> Html) where-    toWidgetBody = toWidget-instance render ~ RY master => ToWidgetBody sub master (render -> Javascript) where-    toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j-instance ToWidgetBody sub master Html where-    toWidgetBody = toWidget--class ToWidgetHead sub master a where-    toWidgetHead :: a -> GWidget sub master ()--instance render ~ RY master => ToWidgetHead sub master (render -> Html) where-    toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head-instance render ~ RY master => ToWidgetHead sub master (render -> Css) where-    toWidgetHead = toWidget-instance render ~ RY master => ToWidgetHead sub master (render -> CssBuilder) where-    toWidgetHead = toWidget-instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where-    toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j-instance ToWidgetHead sub master Html where-    toWidgetHead = toWidgetHead . const---- | Set the page title. Calling 'setTitle' multiple times overrides previously--- set values.-setTitle :: Html -> GWidget sub master ()-setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty---- | Set the page title. Calling 'setTitle' multiple times overrides previously--- set values.-setTitleI :: RenderMessage master msg => msg -> GWidget sub master ()-setTitleI msg = do-    mr <- lift getMessageRender-    setTitle $ toHtml $ mr msg--{-# DEPRECATED addHamletHead, addHtmlHead "Use toWidgetHead instead" #-}-{-# DEPRECATED addHamlet, addHtml, addCassius, addLucius, addJulius "Use toWidget instead" #-}-{-# DEPRECATED addJuliusBody "Use toWidgetBody instead" #-}-{-# DEPRECATED addWidget "addWidget can be omitted" #-}---- | Add a 'Hamlet' to the head tag.-addHamletHead :: HtmlUrl (Route master) -> GWidget sub master ()-addHamletHead = toWidgetHead---- | Add a 'Html' to the head tag.-addHtmlHead :: Html -> GWidget sub master ()-addHtmlHead = toWidgetHead . const---- | Add a 'Hamlet' to the body tag.-addHamlet :: HtmlUrl (Route master) -> GWidget sub master ()-addHamlet = toWidget---- | Add a 'Html' to the body tag.-addHtml :: Html -> GWidget sub master ()-addHtml = toWidget---- | Add another widget. This is defined as 'id', by can help with types, and--- makes widget blocks look more consistent.-addWidget :: GWidget sub master () -> GWidget sub master ()-addWidget = id---- | Add some raw CSS to the style tag. Applies to all media types.-addCassius :: CssUrl (Route master) -> GWidget sub master ()-addCassius = toWidget---- | Identical to 'addCassius'.-addLucius :: CssUrl (Route master) -> GWidget sub master ()-addLucius = toWidget---- | Add some raw CSS to the style tag, for a specific media type.-addCassiusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()-addCassiusMedia m x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty---- | Identical to 'addCassiusMedia'.-addLuciusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()-addLuciusMedia = addCassiusMedia---- | Link to the specified local stylesheet.-addStylesheet :: Route master -> GWidget sub master ()-addStylesheet = flip addStylesheetAttrs []---- | Link to the specified local stylesheet.-addStylesheetAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()-addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty---- | Link to the specified remote stylesheet.-addStylesheetRemote :: Text -> GWidget sub master ()-addStylesheetRemote = flip addStylesheetRemoteAttrs []---- | Link to the specified remote stylesheet.-addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()-addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty--addStylesheetEither :: Either (Route master) Text -> GWidget sub master ()-addStylesheetEither = either addStylesheet addStylesheetRemote--addScriptEither :: Either (Route master) Text -> GWidget sub master ()-addScriptEither = either addScript addScriptRemote---- | Link to the specified local script.-addScript :: Route master -> GWidget sub master ()-addScript = flip addScriptAttrs []---- | Link to the specified local script.-addScriptAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()-addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty---- | Link to the specified remote script.-addScriptRemote :: Text -> GWidget sub master ()-addScriptRemote = flip addScriptRemoteAttrs []---- | Link to the specified remote script.-addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()-addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty---- | Include raw Javascript in the page's script tag.-addJulius :: JavascriptUrl (Route master) -> GWidget sub master ()-addJulius = toWidget---- | Add a new script tag to the body with the contents of this 'Julius'--- template.-addJuliusBody :: JavascriptUrl (Route master) -> GWidget sub master ()-addJuliusBody = toWidgetBody---- | Content for a web page. By providing this datatype, we can easily create--- generic site templates, which would have the type signature:------ > PageContent url -> HtmlUrl url-data PageContent url = PageContent-    { pageTitle :: Html-    , pageHead :: HtmlUrl url-    , pageBody :: HtmlUrl url-    }--whamlet :: QuasiQuoter-whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings--whamletFile :: FilePath -> Q Exp-whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings--whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp-whamletFileWithSettings = NP.hamletFileWithSettings rules--rules :: Q NP.HamletRules-rules = do-    ah <- [|toWidget|]-    let helper qg f = do-            x <- newName "urender"-            e <- f $ VarE x-            let e' = LamE [VarP x] e-            g <- qg-            bind <- [|(>>=)|]-            return $ InfixE (Just g) bind (Just e')-    let ur f = do-            let env = NP.Env-                    (Just $ helper [|liftW getUrlRenderParams|])-                    (Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|])-            f env-    return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b---- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.-ihamletToRepHtml :: RenderMessage master message-                 => HtmlUrlI18n message (Route master)-                 -> GHandler sub master RepHtml-ihamletToRepHtml ih = do-    urender <- getUrlRenderParams-    mrender <- getMessageRender-    return $ RepHtml $ toContent $ ih (toHtml . mrender) urender--tell :: GWData (Route master) -> GWidget sub master ()-tell w = GWidget $ return ((), w)--instance MonadLift (GHandler sub master) (GWidget sub master) where-    lift = GWidget . fmap (\x -> (x, mempty))---- | Type-restricted version of @lift@-liftW :: GHandler sub master a -> GWidget sub master a-liftW = lift---- Instances for GWidget-instance Functor (GWidget sub master) where-    fmap f (GWidget x) = GWidget (fmap (first f) x)-instance Applicative (GWidget sub master) where-    pure a = GWidget $ pure (a, mempty)-    GWidget f <*> GWidget v =-        GWidget $ k <$> f <*> v-      where-        k (a, wa) (b, wb) = (a b, wa `mappend` wb)-instance Monad (GWidget sub master) where-    return = pure-    GWidget x >>= f = GWidget $ do-        (a, wa) <- x-        (b, wb) <- unGWidget (f a)-        return (b, wa `mappend` wb)-instance MonadIO (GWidget sub master) where-    liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO-instance MonadBase IO (GWidget sub master) where-    liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase-instance MonadBaseControl IO (GWidget sub master) where-    data StM (GWidget sub master) a =-        StW (StM (GHandler sub master) (a, GWData (Route master)))-    liftBaseWith f = GWidget $ liftBaseWith $ \runInBase ->-        liftM (\x -> (x, mempty))-        (f $ liftM StW . runInBase . unGWidget)-    restoreM (StW base) = GWidget $ restoreM base--instance MonadUnsafeIO (GWidget sub master) where-    unsafeLiftIO = liftIO-instance MonadThrow (GWidget sub master) where-    monadThrow = liftIO . throwIO-instance MonadResource (GWidget sub master) where-#if MIN_VERSION_resourcet(0,4,0)-    liftResourceT = lift . liftResourceT-#else-    allocate a = lift . allocate a-    register = lift . register-    release = lift . release-    resourceMask = lift . resourceMask-#endif--instance MonadLogger (GWidget sub master) where-#if MIN_VERSION_monad_logger(0, 3, 0)-    monadLoggerLog a b c = lift . monadLoggerLog a b c-#else-    monadLoggerLog a b = lift . monadLoggerLog a b-    monadLoggerLogSource a b c = lift . monadLoggerLogSource a b c-#endif
+ bench/widget.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+-- BigTable benchmark implemented using Hamlet.+{-# LANGUAGE QuasiQuotes #-}++module Main where++import Gauge.Main+import Text.Hamlet+import qualified Data.ByteString.Lazy as L+import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8+import Text.Blaze.Html5 (table, tr, td)+import Text.Blaze.Html (toHtml)+import Data.Int++main :: IO ()+main = defaultMain+    [ bench "bigTable html" $ nf bigTableHtml bigTableData+    , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData+    --, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)+    , bench "bigTable blaze" $ nf bigTableBlaze bigTableData+    ]+  where+    rows :: Int+    rows = 1000++    bigTableData :: [[Int]]+    bigTableData = replicate rows [1..10]+    {-# NOINLINE bigTableData #-}++bigTableHtml :: Show a => [[a]] -> Int64+bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|+<table>+    $forall row <- rows+        <tr>+            $forall cell <- row+                <td>#{show cell}+|]++bigTableHamlet :: Show a => [[a]] ->  Int64+bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|+<table>+    $forall row <- rows+        <tr>+            $forall cell <- row+                <td>#{show cell}+|]++    {-+bigTableWidget :: Show a => [[a]] -> IO Int64+bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|+<table>+    $forall row <- rows+        <tr>+            $forall cell <- row+                <td>#{show cell}+|])+  where+  render _ _ = "foo"+  run (WidgetT w) = do+    (_, GWData { gwdBody = Body x }) <- w undefined+    return x+    -}++bigTableBlaze :: Show a => [[a]] -> Int64+bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ foldMap row t+  where+    row r = tr $ foldMap (td . toHtml . show) r
+ docs/split-route-compilation.md view
@@ -0,0 +1,256 @@+# Split route compilation++As of yesod-core 1.7, route definitions can be split across multiple modules.+A nested route block gets its own datatype, instances, and dispatch generated+in its own module, and the main `mkYesod` splice *delegates* to that module+instead of regenerating everything in one place.++Why you'd want this:++* **Smaller TH splices.** A large site no longer needs one giant `mkYesod`+  splice that regenerates everything whenever any route changes.+* **Parallel compilation.** Each fragment module compiles independently.+* **Locality.** A route group's handlers, datatype, and dispatch live in one+  module, next to each other.+* **Faster test feedback.** Each fragment gets its own `YesodDispatchNested`+  instance, which is enough to dispatch a request on its own.+  [hspec-yesod](https://github.com/parsonsmatt/hspec-yesod) is building on+  this to run specs against a single route fragment, so a spec depends only on+  the handlers it actually exercises — editing an unrelated handler no longer+  recompiles (or relinks) the test module.++## How it works++Any nested route block — a parent declared with a trailing `:` — gets its own+route datatype:++```+/nest NestR:+    /     NestIndexR GET POST+    /#Int NestShowR  GET POST+```++By default, `mkYesod` generates the `NestR` datatype and its dispatch inline,+exactly as in 1.6. But if a `YesodDispatchNested NestR` instance is already in+scope at the splice site (because a separately compiled module generated it),+`mkYesod` delegates to that instance instead. Single-module sites are+unchanged; splitting is opt-in and per-parent.++## Recipe: top-level site++Three modules: a shared route table, the split-out fragment, and the main site.++First, put the route definitions in their own module so both sides can see+them — along with your project's `RouteOpts`. Every splice that touches the+route table should use the same options, so define them once (see+[Fallthrough](#fallthrough) for why fallthrough should be on):++```haskell+module App.Routes.Resources where++import Yesod.Core++appRouteOpts :: RouteOpts+appRouteOpts = setNestedRouteFallthrough True defaultOpts++appRouteOptsFor :: String -> RouteOpts+appRouteOptsFor name = setFocusOnNestedRoute name appRouteOpts++appResources :: [ResourceTree String]+appResources = [parseRoutes|+    /  HomeR GET++    /nest NestR:+        /     NestIndexR GET POST+        /#Int NestShowR  GET POST+|]+```++Then generate the `NestR` fragment in its own module by focusing the splice+on it. The fragment's handlers live here too:++```haskell+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module App.Routes.NestR where++import Yesod.Core+import Data.Text (Text)+import App.Routes.Resources++mkYesodOpts (appRouteOptsFor "NestR") "App" appResources++getNestIndexR :: HandlerFor App Text+getNestIndexR = pure "nest index"++postNestIndexR :: HandlerFor App Text+postNestIndexR = pure "posted"++getNestShowR :: Int -> HandlerFor App Text+getNestShowR _ = pure "nest show"++postNestShowR :: Int -> HandlerFor App Text+postNestShowR _ = pure "posted"+```++Finally, the main module imports the fragment and splices with the same+options:++```haskell+module App where++import Yesod.Core+import App.Routes.Resources+import App.Routes.NestR (NestR (..))++mkYesodOpts appRouteOpts "App" appResources++getHomeR :: HandlerFor App Text+getHomeR = pure "home"+```++Because `App.Routes.NestR` compiled first, the `mkYesodOpts` splice sees the+`YesodDispatchNested NestR` instance and delegates to it rather than+regenerating the `NestR` code. If you want to separate the datatype from the+dispatch further, `mkYesodDataOpts` and `mkYesodDispatchOpts` accept the same+options.++## Recipe: subsites++Subsites split the same way. The data module generates the subsite's route+datatype and nested-fragment instances:++```haskell+module App.SplitSub.Data where++import Yesod.Core++data SplitSub = SplitSub++mkYesodSubData "SplitSub" [parseRoutes|+/ SplitHomeR GET+/nested NestedR:+    / NestedHomeR GET+    /detail/#Int NestedDetailR GET+|]+```++The split-out module holds the nested handlers and generates the+`YesodSubDispatchNested` instance with `mkNestedSubDispatchInstance`:++```haskell+{-# OPTIONS_GHC -Wno-orphans #-}++module App.SplitSub.NestedR (NestedR (..)) where++import Yesod.Core+import Yesod.Core.Dispatch+    (mkNestedSubDispatchInstance, defaultOpts, TyArgs (..))+import App.SplitSub.Data++getNestedHomeR :: SubHandlerFor SplitSub master Text+getNestedHomeR = pure "nested home"++getNestedDetailR :: Int -> SubHandlerFor SplitSub master Text+getNestedDetailR _ = pure "nested detail"++$(mkNestedSubDispatchInstance+    defaultOpts  -- or your project-wide RouteOpts; see Fallthrough below+    "NestedR"+    []        -- no instance context+    NoTyArgs  -- no type arguments (non-parameterized subsite)+    return    -- handler unwrapper+    resourcesSplitSub)  -- the [ResourceTree String] from your routes file+```++`mkNestedSubDispatchInstance` takes the resources as `[ResourceTree String]` —+exactly what the `parseRoutes` quasi-quoter produces — and parses the type+strings internally, failing the splice with an attributable error on a+malformed type rather than a deferred runtime `error`.++And the subsite's `YesodSubDispatch` instance delegates automatically, as long+as the split-out instance is in scope:++```haskell+import App.SplitSub.Data+import App.SplitSub.NestedR ()  -- instance import only; no handlers leak++instance YesodSubDispatch SplitSub master where+    yesodSubDispatch = $(mkYesodSubDispatch resourcesSplitSub)+```++For a subsite defined entirely in one module (including parameterized subsites+like `data MySub a`), `mkYesodSubDispatchInstance "(MyClass a) => MySub a"+resourcesMySub` generates the `YesodSubDispatch` and nested instances in one+splice.++## Linking to nested routes++A nested fragment constructor isn't a `Route App` on its own — its parent may+bind dynamic pieces the fragment doesn't carry. To use a fragment in+`redirect` or `setUrl`, wrap it in `WithParentArgs` together with the parent's+dynamic arguments:++```haskell+redirect (WithParentArgs userId (ProfileEditR "name"))+```++When the parent binds no dynamic pieces, the bare constructor works directly —+generated `RedirectUrl`/`UrlToDispatch` instances fill in the empty parent+arguments:++```haskell+redirect NestIndexR+```++For this reason, if you are splitting up your routes for compilation, it is+recommended to avoid captures in the parent prefix (prefer+`/admin AdminR:` over `/user/#UserId UserR:`). With a static-only prefix,+every fragment constructor is usable directly in `redirect`/`setUrl`, and+`WithParentArgs` never enters the picture. Dynamic pieces can still live on+the individual child routes.++To convert a fragment into its parent's route type explicitly, use+`toParentRoute` from `Yesod.Core.Class.Dispatch.ToParentRoute` (not+re-exported from `Yesod.Core`, since the name is easy to collide with).++## Fallthrough++By default, once dispatch enters a nested parent whose subtree has no matching+child, the response is a 404 — later sibling routes are never tried. This+matters a lot when splitting: the usual first step is wrapping a batch of+previously-flat routes in a new nested group, and with fallthrough off, any+request matching the group's prefix now *commits* to that group. A route+declared later that shares the prefix silently becomes unreachable — flat+dispatch would have kept trying, the grouped version 404s. Enabling+`setNestedRouteFallthrough` restores the flat-dispatch behavior: a parent+whose subtree has no match falls through to the routes after it.++Fallthrough is decided per splice: each module containing a parent route+decides for its own parents. Mixing modules spliced with different options+gives confusingly inconsistent dispatch, which is why the recipe above defines+`appRouteOpts`/`appRouteOptsFor` once and uses them everywhere — don't reach+for `defaultOpts` directly in individual modules.++Related gotcha: a nested parent with *no* leading static path piece matches+unconditionally, so siblings declared after it are unreachable unless+fallthrough is enabled. Give the parent a static segment or enable+fallthrough.++## Troubleshooting++* **`Target 'NestR' was not found in resources.`** — the name passed to+  `setFocusOnNestedRoute` doesn't match any nested parent in the route table.+* **Missing-extension errors** — fragment-generating modules need+  `MultiParamTypeClasses`, and usually `FlexibleContexts` and+  `FlexibleInstances`. GHC's error names the missing extension.+* **Duplicate `RedirectUrl` instance** — the generated convenience instance is+  `OVERLAPPABLE`, so a *more specific* hand-written instance wins, but a+  hand-written instance with the identical head is still a duplicate-instance+  error.
+ src/Yesod/Core.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++module Yesod.Core+    ( -- * Type classes+      Yesod (..)+    , YesodDispatch (..)+    , YesodDispatchNested (..)+    , YesodSubDispatch (..)+    , YesodSubDispatchNested (..)+    , RenderRoute (..)+    -- | Note: the 'toParentRoute' method is intentionally /not/ re-exported+    -- here. It collides with a common local binding name (e.g. the+    -- @toParentRoute@ from @getRouteToParent@), so an @import Yesod@ should not+    -- inject it. Import it from "Yesod.Core.Class.Dispatch.ToParentRoute" when+    -- you need it.+    , ToParentRoute+    , RenderRouteNested (..)+    , ParseRoute (..)+    , RouteAttrs (..)+    -- | @since 1.7.0.0+    , ParseRouteNested (..)+    -- | @since 1.7.0.0+    , RouteAttrsNested (..)+      -- ** Breadcrumbs+    , YesodBreadcrumbs (..)+    , breadcrumbs+      -- * Types+    , Approot (..)+    , FileUpload (..)+    , ErrorResponse (..)+    -- | The field accessors @theParentArgs@\/@parentArgsFor@ are not+    -- re-exported (generic names that would shadow common local bindings);+    -- only the type and its constructor are.+    , WithParentArgs (WithParentArgs)+      -- * Utilities+    , maybeAuthorized+    , widgetToPageContent+      -- * Defaults+    , defaultErrorHandler+    , defaultYesodMiddleware+    , authorizationCheck+      -- * Data types+    , AuthResult (..)+    , unauthorizedI+      -- * Logging+    , defaultMakeLogger+    , defaultMessageLoggerSource+    , defaultShouldLogIO+    , formatLogMessage+    , LogLevel (..)+    , logDebug+    , logInfo+    , logWarn+    , logError+    , logOther+    , logDebugS+    , logInfoS+    , logWarnS+    , logErrorS+    , logOtherS+      -- * Sessions+    , SessionBackend (..)+    , customizeSessionCookies+    , defaultClientSessionBackend+    , envClientSessionBackend+    , clientSessionBackend+    , sslOnlySessions+    , laxSameSiteSessions+    , strictSameSiteSessions+    , sslOnlyMiddleware+    , clientSessionDateCacher+    , loadClientSession+    , Header(..)+    -- * CSRF protection+    , defaultCsrfMiddleware+    , defaultCsrfSetCookieMiddleware+    , csrfSetCookieMiddleware+    , defaultCsrfCheckMiddleware+    , csrfCheckMiddleware+    -- * JS loaders+    , ScriptLoadPosition (..)+    , BottomOfHeadAsync+    -- * Generalizing type classes+    , MonadHandler (..)+    , MonadWidget (..)+      -- * Approot+    , guessApproot+    , guessApprootOr+    , getApprootText+      -- * Misc+    , yesodVersion+    , yesodRender+    , Yesod.Core.runFakeHandler+      -- * LiteApp+    , module Yesod.Core.Internal.LiteApp+      -- * Low-level+    , yesodRunner+      -- * Re-exports+    , module Yesod.Core.Content+    , module Yesod.Core.Dispatch+    , module Yesod.Core.Handler+    , module Yesod.Core.Widget+    , module Yesod.Core.Json+    , module Text.Shakespeare.I18N+    , module Yesod.Core.Internal.Util+    , module Text.Blaze.Html+    , MonadTrans (..)+    , MonadIO (..)+    , MonadUnliftIO (..)+    , MonadResource (..)+    , MonadLogger+      -- * Commonly referenced functions/datatypes+    , Application+      -- * Utilities+    , showIntegral+    , readIntegral+      -- * Shakespeare+      -- ** Hamlet+    , hamlet+    , shamlet+    , xhamlet+    , HtmlUrl+      -- ** Julius+    , julius+    , JavascriptUrl+    , renderJavascriptUrl+      -- ** Cassius/Lucius+    , cassius+    , lucius+    , CssUrl+    , renderCssUrl+    ) where++import Yesod.Core.Content+import Yesod.Core.Dispatch+import Yesod.Core.Handler+import Yesod.Core.Class.Handler+import Yesod.Core.Widget+import Yesod.Core.Json+import Yesod.Core.Types+import Text.Shakespeare.I18N+import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)+import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)++import Control.Monad.Logger+import Control.Monad.Trans.Class (MonadTrans (..))+import Yesod.Core.Internal.Session+import Yesod.Core.Internal.Run (yesodRunner, yesodRender)+import Yesod.Core.Class.Yesod+import Yesod.Core.Class.Dispatch+import Yesod.Core.Class.Breadcrumbs+import qualified Yesod.Core.Internal.Run+import qualified Paths_yesod_core+import Data.Version (showVersion)+import Yesod.Routes.Class+import UnliftIO (MonadIO (..), MonadUnliftIO (..))+import Yesod.Core.Class.Dispatch.ToParentRoute++import Control.Monad.Trans.Resource (MonadResource (..))+import Yesod.Core.Internal.LiteApp+import Text.Hamlet+import Text.Cassius+import Text.Lucius+import Text.Julius+import Network.Wai (Application)++runFakeHandler :: (Yesod site, MonadIO m) =>+                  SessionMap+               -> (site -> Logger)+               -> site+               -> HandlerT site IO a+               -> m (Either ErrorResponse a)+runFakeHandler = Yesod.Core.Internal.Run.runFakeHandler+{-# DEPRECATED runFakeHandler "import runFakeHandler from Yesod.Core.Unsafe" #-}++-- | Return an 'Unauthorized' value, with the given i18n message.+unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult+unauthorizedI msg = do+    mr <- getMessageRender+    return $ Unauthorized $ mr msg++yesodVersion :: String+yesodVersion = showVersion Paths_yesod_core.version++-- | Return the same URL if the user is authorized to see it.+--+-- Built on top of 'isAuthorized'. This is useful for building page that only+-- contain links to pages the user is allowed to see.+maybeAuthorized :: Yesod site+                => Route site+                -> Bool -- ^ is this a write request?+                -> HandlerT site IO (Maybe (Route site))+maybeAuthorized r isWrite = do+    x <- isAuthorized r isWrite+    return $ if x == Authorized then Just r else Nothing++showIntegral :: Integral a => a -> String+showIntegral x = show (fromIntegral x :: Integer)++readIntegral :: Num a => String -> Maybe a+readIntegral s =+    case reads s of+        (i, _):_ -> Just $ fromInteger i+        [] -> Nothing
+ src/Yesod/Core/Class/Breadcrumbs.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Core.Class.Breadcrumbs where++import Yesod.Core.Handler+import Yesod.Routes.Class+import Data.Text (Text)++-- | A type-safe, concise method of creating breadcrumbs for pages. For each+-- resource, you declare the title of the page and the parent resource (if+-- present).+class YesodBreadcrumbs site where+    -- | Returns the title and the parent resource, if available. If you return+    -- a 'Nothing', then this is considered a top-level page.+    breadcrumb :: Route site -> HandlerFor site (Text , Maybe (Route site))++-- | Gets the title of the current page and the hierarchy of parent pages,+-- along with their respective titles.+breadcrumbs :: (YesodBreadcrumbs site, Show (Route site), Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)])+breadcrumbs = do+    x <- getCurrentRoute+    case x of+        Nothing -> return ("Not found", [])+        Just y -> do+            (title, next) <- breadcrumb y+            z <- go [] next+            return (title, z)+  where+    go back Nothing = return back+    go back (Just this)+      | this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this+      | otherwise = do+          (title, next) <- breadcrumb this+          go ((this, title) : back) next
+ src/Yesod/Core/Class/Dispatch.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Yesod.Core.Class.Dispatch where++import Data.ByteString.Builder (toLazyByteString, byteString)+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import Network.HTTP.Types (status301, status307)+import Yesod.Core.Class.Dispatch.ToParentRoute+import Yesod.Core.Class.Yesod+import Yesod.Core.Content (ToTypedContent (..))+import Yesod.Core.Handler (sendWaiApplication, RedirectUrl, notFound)+import Yesod.Core.Internal.Run+import Yesod.Core.Types+import Yesod.Routes.Class+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as BL+import qualified Network.Wai as W++-- | This class is automatically instantiated when you use the template haskell+-- mkYesod function. You should never need to deal with it directly.+class Yesod site => YesodDispatch site where+    yesodDispatch :: YesodRunnerEnv site -> W.Application++-- | This class enables you to dispatch on a route fragment without needing+-- to know how to dispatch on the entire route structure. This allows you+-- to break up route generation into multiple files.+--+-- For details on use, see 'setFocusOnNestedRoute'.+--+-- @since 1.7.0.0+class RenderRouteNested a => YesodDispatchNested a where+    -- | Dispatches a request to a nested route fragment.+    --+    -- The implementation uses the full WAI 'Request' to determine if the+    -- remaining path (after the parent route) matches any child routes.+    -- Returns 'Nothing' if no child routes match (for fallthrough to other+    -- routes), or 'Just' a continuation that handles the request.+    --+    -- The parent depth (number of path pieces consumed by the parent route)+    -- is statically known during Template Haskell generation and baked into+    -- the generated instance.+    --+    -- @since 1.7.0.0+    yesodDispatchNested+        :: (Yesod (ParentSite a))+        => Proxy a+        -- ^ Type proxy to resolve ambiguity from non-injective type families+        -> ParentArgs a+        -- ^ The dynamic arguments from the parent route+        -> (a -> Route (ParentSite a))+        -- ^ Function to wrap the nested route in the parent constructor+        -> YesodRunnerEnv (ParentSite a)+        -- ^ The runner environment+        -> W.Request+        -- ^ The full WAI request+        -> Maybe ((W.Response -> IO W.ResponseReceived) -> IO W.ResponseReceived)+        -- ^ Returns 'Nothing' for fallthrough, or 'Just' a continuation+        -- that completes the 'Application' type when given a respond callback++-- | 'YesodDispatchNested' is a more flexible class than 'YesodDispatch',+-- and this instance is the proof. Given a @'Route' site@ we can dispatch+-- on it as normal, so this code path works. This allows us to create+-- generalized helpers and reuse them, ensuring that nested and top-level+-- dispatch remain equivalent. This instance therefore always returns+-- @'Just'@ — committing to 'yesodDispatch', which itself terminates in+-- a 404 on a miss — rather than the 'Nothing' that the class haddock+-- describes for /fragment/ instances. The only intended caller is the+-- terminal authority 'toWaiAppYreNested', where that 404 is exactly the+-- right answer; do not rely on this instance to signal fallthrough.+instance YesodDispatch site => YesodDispatchNested (Route site) where+    yesodDispatchNested _ _ _ yre req = Just $ yesodDispatch yre req++-- | Build a WAI 'W.Application' for @site@, indexed by a @url@ type that can+-- be rendered to a route of @site@ (via 'RedirectUrl').+--+-- Note that dispatch is purely path-based: the hand-written instances below+-- discard the @url@ value (@urlToDispatch _ = yesodDispatch@) and route on the+-- request's @pathInfo@. The @url@ argument exists only to select the instance+-- and to carry the 'RedirectUrl' constraint — it is not consulted at runtime.+--+-- This is equivalent to 'YesodDispatch' but allows us to vary on the+-- @url@ type, which lets us demand additional constraints in test+-- contexts.+--+-- @since 1.7.0.0+class RedirectUrl site url => UrlToDispatch url site where+    -- | @since 1.7.0.0+    urlToDispatch :: url -> YesodRunnerEnv site -> W.Application++instance YesodDispatch site => UrlToDispatch (Route site) site where+    urlToDispatch _ = yesodDispatch++instance (YesodDispatch site, RedirectUrl site (Route site, a)) => UrlToDispatch (Route site, a) site where+    urlToDispatch _ = yesodDispatch++instance YesodDispatch site => UrlToDispatch Text site where+    urlToDispatch _ = yesodDispatch++instance YesodDispatch site => UrlToDispatch String site where+    urlToDispatch _ = yesodDispatch++-- | This instance is the pattern upon which 'UrlToDispatch' instances are+-- generated for subsite fragments. Given the constraints, we are able to+-- call 'toWaiAppYreNested' at the @route@ type with the correct arguments.+-- This allows us to create an application for a fragment of a site.+--+-- @since 1.7.0.0+instance+    ( ParentSite route ~ site+    , YesodDispatchNested route+    , RedirectUrl site (WithParentArgs route)+    , Yesod site+    , ToParentRoute route+    )+  =>+    UrlToDispatch (WithParentArgs route) site+  where+    urlToDispatch (WithParentArgs args _) =+        toWaiAppYreNested (Proxy :: Proxy route) args++class YesodSubDispatch sub master where+    yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application++-- | Like 'YesodDispatchNested', but for subsites. This class enables+-- class-based delegation for nested routes within subsites, allowing+-- module separation and symmetry with 'YesodDispatchNested'.+--+-- When a 'YesodSubDispatchNested' instance exists for a nested route type,+-- 'mkYesodSubDispatch' will delegate to it instead of inlining the dispatch.+-- Use 'mkYesodSubDispatchInstance' to generate both 'YesodSubDispatch' and+-- 'YesodSubDispatchNested' instances in one splice.+--+-- @since 1.7.0.0+class RenderRouteNested a => YesodSubDispatchNested a where+    -- | Dispatches a request for a nested route fragment within a subsite.+    --+    -- Similar to 'yesodDispatchNested', but works with 'YesodSubRunnerEnv'+    -- instead of 'YesodRunnerEnv', making it suitable for subsites.+    -- The @master@ type is universally quantified since it's not determined+    -- by the nested route type.+    --+    -- @since 1.7.0.0+    yesodSubDispatchNested+        :: Proxy a+        -- ^ Type proxy to resolve ambiguity from non-injective type families+        -> ParentArgs a+        -- ^ The dynamic arguments from the parent route+        -> (a -> Route (ParentSite a))+        -- ^ Function to wrap the nested route in the parent constructor+        -> YesodSubRunnerEnv (ParentSite a) master+        -- ^ The subsite runner environment+        -> W.Request+        -- ^ The full WAI request+        -> Maybe ((W.Response -> IO W.ResponseReceived) -> IO W.ResponseReceived)+        -- ^ Returns 'Nothing' for fallthrough, or 'Just' a continuation++instance YesodSubDispatch WaiSubsite master where+    yesodSubDispatch YesodSubRunnerEnv {..} = app+      where+        WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv++instance YesodSubDispatch WaiSubsiteWithAuth master where+  yesodSubDispatch YesodSubRunnerEnv {..} req =+      ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req+    where+      route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []+      WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv+      handlert = sendWaiApplication set++subHelper+  :: ToTypedContent content+  => SubHandlerFor child master content+  -> YesodSubRunnerEnv child master+  -> Maybe (Route child)+  -> W.Application+subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =+    ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)+  where+    handler = fmap toTypedContent $ HandlerFor $ \hd ->+      let rhe = handlerEnv hd+          rhe' = rhe+            { rheRoute = mroute+            , rheChild = ysreGetSub $ yreSite ysreParentEnv+            , rheRouteToMaster = ysreToParentRoute+            }+       in f hd { handlerEnv = rhe' }++-- | Build a WAI 'W.Application' that dispatches starting at a nested route+-- fragment @a@ (rather than the whole @'Route' site@), given a+-- 'YesodRunnerEnv' for the parent site and the parent route's 'ParentArgs'.+-- Handles @cleanPath@ redirects and a terminal 404 just like 'toWaiAppYre'.+--+-- @since 1.7.0.0+toWaiAppYreNested+    :: (Yesod (ParentSite a), YesodDispatchNested a, ToParentRoute a)+    => Proxy a+    -> ParentArgs a+    -> YesodRunnerEnv (ParentSite a)+    -> W.Application+toWaiAppYreNested proxy parentArgs yre req =+    case cleanPath site $ W.pathInfo req of+        Left pieces -> sendRedirect site pieces req+        Right pieces -> do+            let mapplication =+                    yesodDispatchNested proxy parentArgs (toParentRoute parentArgs) yre req+                        { W.pathInfo = pieces+                        }+            case mapplication of+                Nothing ->+                    yesodRunner (notFound :: HandlerFor site ()) yre Nothing req+                Just k ->+                    k+  where+    site = yreSite yre+    sendRedirect :: Yesod master => master -> [Text] -> W.Application+    sendRedirect y segments' env sendResponse =+         sendResponse $ W.responseLBS status+                [ ("Content-Type", "text/plain")+                , ("Location", BL.toStrict $ toLazyByteString dest')+                ] "Redirecting"+      where+        -- Ensure that non-GET requests get redirected correctly. See:+        -- https://github.com/yesodweb/yesod/issues/951+        status+            | W.requestMethod env == "GET" = status301+            | otherwise                    = status307++        dest = joinPath y (resolveApproot y env) segments' []+        dest' =+            if S.null (W.rawQueryString env)+                then dest+                else dest `mappend`+                     byteString (W.rawQueryString env)
+ src/Yesod/Core/Class/Dispatch/ToParentRoute.hs view
@@ -0,0 +1,18 @@+{-# language FlexibleContexts #-}++module Yesod.Core.Class.Dispatch.ToParentRoute where++import Yesod.Routes.Class++-- | Reconstruct a full parent route from a nested route fragment and its+-- 'ParentArgs' (the dynamic pieces consumed by the ancestor parents). This is+-- what lets a fragment dispatched in its own module be rendered back into the+-- master site's @'Route' ('ParentSite' a)@.+--+-- @since 1.7.0.0+class (RenderRoute (ParentSite a)) => ToParentRoute a where+    -- | @since 1.7.0.0+    toParentRoute :: ParentArgs a -> a -> Route (ParentSite a)++instance (RenderRoute a) => ToParentRoute (Route a) where+    toParentRoute _ = id
+ src/Yesod/Core/Class/Handler.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Yesod.Core.Class.Handler+    ( MonadHandler (..)+    , MonadWidget (..)+    , liftHandlerT+    , liftWidgetT+    ) where++import Yesod.Core.Types+import Control.Monad.Logger (MonadLogger)+import Control.Monad.Trans.Resource (MonadResource)+import Control.Monad.Trans.Class (lift)+import Data.Conduit.Internal (Pipe, ConduitM)++import Control.Monad.Trans.Identity ( IdentityT)+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.List     ( ListT    )+#endif+import Control.Monad.Trans.Maybe    ( MaybeT   )+import Control.Monad.Trans.Except   ( ExceptT  )+import Control.Monad.Trans.Reader   ( ReaderT  )+import Control.Monad.Trans.State    ( StateT   )+import Control.Monad.Trans.Writer   ( WriterT  )+import Control.Monad.Trans.RWS      ( RWST     )+import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )+import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )++-- FIXME should we just use MonadReader instances instead?+class (MonadResource m, MonadLogger m) => MonadHandler m where+    type HandlerSite m+    type SubHandlerSite m+    liftHandler :: HandlerFor (HandlerSite m) a -> m a+    liftSubHandler :: SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a++liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a+liftHandlerT = liftHandler+{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-}++instance MonadHandler (HandlerFor site) where+    type HandlerSite (HandlerFor site) = site+    type SubHandlerSite (HandlerFor site) = site+    liftHandler = id+    {-# INLINE liftHandler #-}+    liftSubHandler (SubHandlerFor f) = HandlerFor f+    {-# INLINE liftSubHandler #-}++instance MonadHandler (SubHandlerFor sub master) where+    type HandlerSite (SubHandlerFor sub master) = master+    type SubHandlerSite (SubHandlerFor sub master) = sub+    liftHandler (HandlerFor f) = SubHandlerFor $ \hd -> f hd+      { handlerEnv =+          let rhe = handlerEnv hd+           in rhe+                { rheRoute = fmap (rheRouteToMaster rhe) (rheRoute rhe)+                , rheRouteToMaster = id+                , rheChild = rheSite rhe+                }+      }+    {-# INLINE liftHandler #-}+    liftSubHandler = id+    {-# INLINE liftSubHandler #-}++instance MonadHandler (WidgetFor site) where+    type HandlerSite (WidgetFor site) = site+    type SubHandlerSite (WidgetFor site) = site+    liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler+    {-# INLINE liftHandler #-}+    liftSubHandler (SubHandlerFor f) = WidgetFor $ f . wdHandler+    {-# INLINE liftSubHandler #-}++#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler+#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler+GO(IdentityT)+#if !MIN_VERSION_transformers(0,6,0)+GO(ListT)+#endif+GO(MaybeT)+GO(ExceptT e)+GO(ReaderT r)+GO(StateT s)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)+GO(Pipe l i o u)+GO(ConduitM i o)+#undef GO+#undef GOX++class MonadHandler m => MonadWidget m where+    liftWidget :: WidgetFor (HandlerSite m) a -> m a+instance MonadWidget (WidgetFor site) where+    liftWidget = id+    {-# INLINE liftWidget #-}++liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a+liftWidgetT = liftWidget+{-# DEPRECATED liftWidgetT "Use liftWidget instead" #-}++#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget+#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget+GO(IdentityT)+#if !MIN_VERSION_transformers(0,6,0)+GO(ListT)+#endif+GO(MaybeT)+GO(ExceptT e)+GO(ReaderT r)+GO(StateT s)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)+GO(Pipe l i o u)+GO(ConduitM i o)+#undef GO+#undef GOX
+ src/Yesod/Core/Class/Yesod.hs view
@@ -0,0 +1,947 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Yesod.Core.Class.Yesod where++import           Yesod.Core.Content+import           Yesod.Core.Handler++import           Yesod.Routes.Class++import           Data.ByteString.Builder            (Builder)+import           Data.Text.Encoding                 (encodeUtf8Builder)+import           Control.Arrow                      ((***), second)+import           Control.Exception                  (bracket)+import           Control.Monad                      (forM, when, void)+import           Control.Monad.IO.Class             (MonadIO (liftIO))+import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelOther),+                                                     LogSource, logErrorS)+import           Control.Monad.Trans.Resource       (InternalState, createInternalState, closeInternalState)+import qualified Data.ByteString.Char8              as S8+import qualified Data.ByteString.Lazy               as L+import Data.Aeson (object, (.=))+import           Data.List                          (foldl', nub)+import qualified Data.Map                           as Map+import           Data.Maybe                         (catMaybes)+import           Data.Monoid                        (Last (..))+import           Data.Text                          (Text)+import qualified Data.Text                          as T+import qualified Data.Text.Encoding                 as TE+import qualified Data.Text.Encoding.Error           as TEE+import           Data.Text.Lazy.Builder             (toLazyText)+import           Data.Text.Lazy.Encoding            (encodeUtf8)+import           Data.Word                          (Word64)+import           Language.Haskell.TH.Syntax         (Loc (..))+import           Network.HTTP.Types                 (encodePath)+import qualified Network.Wai                        as W+import           Network.Wai.Parse                  (lbsBackEnd,+                                                     tempFileBackEnd)+import           Network.Wai.Logger                 (ZonedDate, clockDateCacher)+import           System.Log.FastLogger+import           Text.Blaze                         (customAttribute, textTag,+                                                     toValue, (!),+                                                     preEscapedToMarkup)+import qualified Text.Blaze.Html5                   as TBH+import           Text.Hamlet+import           Text.Julius+import qualified Web.ClientSession                  as CS+import           Web.Cookie                         (SetCookie (..), parseCookies, sameSiteLax,+                                                     sameSiteStrict, SameSiteOption, defaultSetCookie)+import           Yesod.Core.Types+import           Yesod.Core.Internal.Session+import           Yesod.Core.Widget+import Data.CaseInsensitive (CI)+import qualified Network.Wai.Request+import Data.IORef+import UnliftIO (SomeException, catch, MonadUnliftIO)++-- | Define settings for a Yesod applications. All methods have intelligent+-- defaults, and therefore no implementation is required.+class RenderRoute site => Yesod site where+    -- | An absolute URL to the root of the application. Do not include+    -- trailing slash.+    --+    -- Default value: 'guessApproot'. If you know your application root+    -- statically, it will be more efficient and more reliable to instead use+    -- 'ApprootStatic' or 'ApprootMaster'. If you do not need full absolute+    -- URLs, you can use 'ApprootRelative' instead.+    --+    -- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'.+    approot :: Approot site+    approot = guessApproot++    -- | @since 1.6.24.0+    --  allows the user to specify how exceptions are cought.+    --  by default all async exceptions are thrown and synchronous+    --  exceptions render a 500 page.+    -- To catch all exceptions (even async) to render a 500 page,+    -- set this to 'UnliftIO.Exception.catchSyncOrAsync'. Beware+    -- this may have negative effects with functions like 'timeout'.+    catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a+    catchHandlerExceptions _ = catch++    -- | Output error response pages.+    --+    -- Default value: 'defaultErrorHandler'.+    errorHandler :: ErrorResponse -> HandlerFor site TypedContent+    errorHandler = defaultErrorHandler++    -- | Applies some form of layout to the contents of a page.+    defaultLayout :: WidgetFor site () -> HandlerFor site Html+    defaultLayout w = do+        p <- widgetToPageContent w+        msgs <- getMessages+        withUrlRenderer [hamlet|+            $newline never+            $doctype 5+            <html>+                <head>+                    <title>#{pageTitle p}+                    $maybe description <- pageDescription p+                      <meta name="description" content="#{description}">+                    ^{pageHead p}+                <body>+                    $forall (status, msg) <- msgs+                        <p class="message #{status}">#{msg}+                    ^{pageBody p}+            |]++    -- | Override the rendering function for a particular URL and query string+    -- parameters. One use case for this is to offload static hosting to a+    -- different domain name to avoid sending cookies.+    --+    -- For backward compatibility default implementation is in terms of+    -- 'urlRenderOverride', probably ineffective+    --+    -- Since 1.4.23+    urlParamRenderOverride :: site+                           -> Route site+                           -> [(T.Text, T.Text)] -- ^ query string+                           -> Maybe Builder+    urlParamRenderOverride _ _ _ = Nothing++    -- | Determine if a request is authorized or not.+    --+    -- Return 'Authorized' if the request is authorized,+    -- 'Unauthorized' a message if unauthorized.+    -- If authentication is required, return 'AuthenticationRequired'.+    isAuthorized :: Route site+                 -> Bool -- ^ is this a write request?+                 -> HandlerFor site AuthResult+    isAuthorized _ _ = return Authorized++    -- | Determines whether the current request is a write request. By default,+    -- this assumes you are following RESTful principles, and determines this+    -- from request method. In particular, all except the following request+    -- methods are considered write: GET HEAD OPTIONS TRACE.+    --+    -- This function is used to determine if a request is authorized; see+    -- 'isAuthorized'.+    isWriteRequest :: Route site -> HandlerFor site Bool+    isWriteRequest _ = do+        wai <- waiRequest+        return $ W.requestMethod wai `notElem`+            ["GET", "HEAD", "OPTIONS", "TRACE"]++    -- | The default route for authentication.+    --+    -- Used in particular by 'isAuthorized', but library users can do whatever+    -- they want with it.+    authRoute :: site -> Maybe (Route site)+    authRoute _ = Nothing++    -- | A function used to clean up path segments. It returns 'Right' with a+    -- clean path or 'Left' with a new set of pieces the user should be+    -- redirected to. The default implementation enforces:+    --+    -- * No double slashes+    --+    -- * There is no trailing slash.+    --+    -- Note that versions of Yesod prior to 0.7 used a different set of rules+    -- involing trailing slashes.+    cleanPath :: site -> [Text] -> Either [Text] [Text]+    cleanPath _ s =+        if corrected == s+            then Right $ map dropDash s+            else Left corrected+      where+        corrected = filter (not . T.null) s+        dropDash t+            | T.all (== '-') t = T.drop 1 t+            | otherwise = t++    -- | Builds an absolute URL by concatenating the application root with the+    -- pieces of a path and a query string, if any.+    -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'.+    joinPath :: site+             -> T.Text -- ^ application root+             -> [T.Text] -- ^ path pieces+             -> [(T.Text, T.Text)] -- ^ query string+             -> Builder+    joinPath _ ar pieces' qs' =+        encodeUtf8Builder ar `mappend` encodePath pieces qs+      where+        pieces = if null pieces' then [""] else map addDash pieces'+        qs = map (TE.encodeUtf8 *** go) qs'+        go "" = Nothing+        go x = Just $ TE.encodeUtf8 x+        addDash t+            | T.all (== '-') t = T.cons '-' t+            | otherwise = t++    -- | This function is used to store some static content to be served as an+    -- external file. The most common case of this is stashing CSS and+    -- JavaScript content in an external file; the "Yesod.Widget" module uses+    -- this feature.+    --+    -- The return value is 'Nothing' if no storing was performed; this is the+    -- default implementation. A 'Just' 'Left' gives the absolute URL of the+    -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is+    -- necessary when you are serving the content outside the context of a+    -- Yesod application, such as via memcached.+    addStaticContent :: Text -- ^ filename extension+                     -> Text -- ^ mime-type+                     -> L.ByteString -- ^ content+                     -> HandlerFor site (Maybe (Either Text (Route site, [(Text, Text)])))+    addStaticContent _ _ _ = return Nothing++    -- | Maximum allowed length of the request body, in bytes.+    -- This method may be ignored if 'maximumContentLengthIO' is overridden.+    --+    -- If @Nothing@, no maximum is applied.+    --+    -- Default: 2 megabytes.+    maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64+    maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes++    -- | Maximum allowed length of the request body, in bytes. This is similar+    -- to 'maximumContentLength', but the result lives in @IO@. This allows+    -- you to dynamically change the maximum file size based on some external+    -- source like a database or an @IORef@.+    --+    -- The default implementation uses 'maximumContentLength'. Future version of yesod will+    -- remove 'maximumContentLength' and use this method exclusively.+    --+    -- @since 1.6.13+    maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)+    maximumContentLengthIO a b = pure $ maximumContentLength a b++    -- | Creates a @Logger@ to use for log messages.+    --+    -- Note that a common technique (endorsed by the scaffolding) is to create+    -- a @Logger@ value and place it in your foundation datatype, and have this+    -- method return that already created value. That way, you can use that+    -- same @Logger@ for printing messages during app initialization.+    --+    -- Default: the 'defaultMakeLogger' function.+    makeLogger :: site -> IO Logger+    makeLogger _ = defaultMakeLogger++    -- | Send a message to the @Logger@ provided by @getLogger@.+    --+    -- Default: the 'defaultMessageLoggerSource' function, using+    -- 'shouldLogIO' to check whether we should log.+    messageLoggerSource :: site+                        -> Logger+                        -> Loc -- ^ position in source code+                        -> LogSource+                        -> LogLevel+                        -> LogStr -- ^ message+                        -> IO ()+    messageLoggerSource site = defaultMessageLoggerSource $ shouldLogIO site++    -- | Where to Load sripts from. We recommend the default value,+    -- 'BottomOfBody'.+    jsLoader :: site -> ScriptLoadPosition site+    jsLoader _ = BottomOfBody++    -- | Default attributes to put on the JavaScript <script> tag+    -- generated for julius files+    jsAttributes :: site -> [(Text, Text)]+    jsAttributes _ = []++    -- | Same as @jsAttributes@ but allows you to run arbitrary Handler code+    --+    -- This is useful if you need to add a randomised nonce value to the script+    -- tag generated by @widgetFile@. If this function is overridden then+    -- @jsAttributes@ is ignored.+    --+    -- @since 1.6.16+    jsAttributesHandler :: HandlerFor site [(Text, Text)]+    jsAttributesHandler = jsAttributes <$> getYesod++    -- | Create a session backend. Returning 'Nothing' disables+    -- sessions. If you'd like to change the way that the session+    -- cookies are created, take a look at+    -- 'customizeSessionCookies'.+    --+    -- Default: Uses clientsession with a 2 hour timeout.+    makeSessionBackend :: site -> IO (Maybe SessionBackend)+    makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 CS.defaultKeyFile++    -- | How to store uploaded files.+    --+    -- Default: When the request body is greater than 50kb, store in a temp+    -- file. For chunked request bodies, store in a temp file. Otherwise, store+    -- in memory.+    fileUpload :: site -> W.RequestBodyLength -> FileUpload+    fileUpload _ (W.KnownLength size)+        | size <= 50000 = FileUploadMemory lbsBackEnd+    fileUpload _ _ = FileUploadDisk tempFileBackEnd++    -- | Should we log the given log source/level combination.+    --+    -- Default: the 'defaultShouldLogIO' function.+    --+    -- Since 1.2.4+    shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool+    shouldLogIO _ = defaultShouldLogIO++    -- | A Yesod middleware, which will wrap every handler function. This+    -- allows you to run code before and after a normal handler.+    --+    -- Default: the 'defaultYesodMiddleware' function.+    --+    -- Since: 1.1.6+    yesodMiddleware :: ToTypedContent res => HandlerFor site res -> HandlerFor site res+    yesodMiddleware = defaultYesodMiddleware++    -- | How to allocate an @InternalState@ for each request.+    --+    -- The default implementation is almost always what you want. However, if+    -- you know that you are never taking advantage of the @MonadResource@+    -- instance in your handler functions, setting this to a dummy+    -- implementation can provide a small optimization. Only do this if you+    -- really know what you're doing, otherwise you can turn safe code into a+    -- runtime error!+    --+    -- Since 1.4.2+    yesodWithInternalState :: site -> Maybe (Route site) -> (InternalState -> IO a) -> IO a+    yesodWithInternalState _ _ = bracket createInternalState closeInternalState+    {-# INLINE yesodWithInternalState #-}++    -- | Convert a title and HTML snippet into a 'Widget'. Used+    -- primarily for wrapping up error messages for better display.+    --+    -- @since 1.4.30+    defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site ()+    defaultMessageWidget title body = do+        setTitle title+        toWidget+            [hamlet|+                <h1>#{title}+                ^{body}+            |]++-- | Default implementation of 'makeLogger'. Sends to stdout and+-- automatically flushes on each write.+--+-- Since 1.4.10+defaultMakeLogger :: IO Logger+defaultMakeLogger = do+    loggerSet' <- newStdoutLoggerSet defaultBufSize+    (getter, _) <- clockDateCacher+    return $! Logger loggerSet' getter++-- | Default implementation of 'messageLoggerSource'. Checks if the+-- message should be logged using the provided function, and if so,+-- formats using 'formatLogMessage'. You can use 'defaultShouldLogIO'+-- as the provided function.+--+-- Since 1.4.10+defaultMessageLoggerSource ::+       (LogSource -> LogLevel -> IO Bool) -- ^ Check whether we should+                                          -- log this+    -> Logger+    -> Loc -- ^ position in source code+    -> LogSource+    -> LogLevel+    -> LogStr -- ^ message+    -> IO ()+defaultMessageLoggerSource ckLoggable logger loc source level msg = do+    loggable <- ckLoggable source level+    when loggable $+        formatLogMessage (loggerDate logger) loc source level msg >>=+        loggerPutStr logger++-- | Default implementation of 'shouldLog'. Logs everything at or+-- above 'LevelInfo'.+--+-- Since 1.4.10+defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool+defaultShouldLogIO _ level = return $ level >= LevelInfo++-- | Default implementation of 'yesodMiddleware'. Adds the response header+-- \"Vary: Accept, Accept-Language\", \"X-XSS-Protection: 1; mode=block\", and+-- performs authorization checks.+--+-- Since 1.2.0+defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res+defaultYesodMiddleware handler = do+    addHeader "Vary" "Accept, Accept-Language"+    addHeader "X-XSS-Protection" "1; mode=block"+    authorizationCheck+    handler++-- | Defends against session hijacking by setting the secure bit on session+-- cookies so that browsers will not transmit them over http. With this+-- setting on, it follows that the server will regard requests made over+-- http as sessionless, because the session cookie will not be included in+-- the request. Use this as part of a total security measure which also+-- includes disabling HTTP traffic to the site or issuing redirects from+-- HTTP urls, and composing 'sslOnlyMiddleware' with the site's+-- 'yesodMiddleware'.+--+-- Since 1.4.7+sslOnlySessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)+sslOnlySessions = (fmap . fmap) secureSessionCookies+  where+    setSecureBit cookie = cookie { setCookieSecure = True }+    secureSessionCookies = customizeSessionCookies setSecureBit++-- | Helps defend against CSRF attacks by setting the SameSite attribute on+-- session cookies to Lax. With the Lax setting, the cookie will be sent with same-site+-- requests, and with cross-site top-level navigations.+--+-- This option is liable to change in future versions of Yesod as the spec evolves.+-- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.+--+-- @since 1.4.23+laxSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)+laxSameSiteSessions = sameSiteSession sameSiteLax++-- | Helps defend against CSRF attacks by setting the SameSite attribute on+-- session cookies to Strict. With the Strict setting, the cookie will only be+-- sent with same-site requests.+--+-- This option is liable to change in future versions of Yesod as the spec evolves.+-- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.+--+-- @since 1.4.23+strictSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)+strictSameSiteSessions = sameSiteSession sameSiteStrict++sameSiteSession :: SameSiteOption -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)+sameSiteSession s = (fmap . fmap) secureSessionCookies+  where+    sameSite cookie = cookie { setCookieSameSite = Just s }+    secureSessionCookies = customizeSessionCookies sameSite++-- | Apply a Strict-Transport-Security header with the specified timeout to+-- all responses so that browsers will rewrite all http links to https+-- until the timeout expires. For security, the max-age of the STS header+-- should always equal or exceed the client sessions timeout. This defends+-- against SSL-stripping man-in-the-middle attacks. It is only effective if+-- a secure connection has already been made; Strict-Transport-Security+-- headers are ignored over HTTP.+--+-- Since 1.4.7+sslOnlyMiddleware :: Int -- ^ minutes+                  -> HandlerFor site res+                  -> HandlerFor site res+sslOnlyMiddleware timeout handler = do+    addHeader "Strict-Transport-Security"+              $ T.pack $ concat [ "max-age="+                                , show $ timeout * 60+                                , "; includeSubDomains"+                                ]+    handler++-- | Check if a given request is authorized via 'isAuthorized' and+-- 'isWriteRequest'.+--+-- Since 1.2.0+authorizationCheck :: Yesod site => HandlerFor site ()+authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl+  where+    checkUrl url = do+        isWrite <- isWriteRequest url+        ar <- isAuthorized url isWrite+        case ar of+            Authorized -> return ()+            AuthenticationRequired -> do+                master <- getYesod+                case authRoute master of+                    Nothing -> void notAuthenticated+                    Just url' ->+                      void $ selectRep $ do+                          provideRepType typeHtml $ do+                              setUltDestCurrent+                              void $ redirect url'+                          provideRepType typeJson $+                              void notAuthenticated+            Unauthorized s' -> permissionDenied s'++-- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.+--+-- Since 1.4.14+defaultCsrfCheckMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res+defaultCsrfCheckMiddleware handler =+    csrfCheckMiddleware+        handler+        (getCurrentRoute >>= maybe (return False) isWriteRequest)+        defaultCsrfHeaderName+        defaultCsrfParamName++-- | Looks up the CSRF token from the request headers or POST parameters. If the value doesn't match the token stored in the session,+-- this function throws a 'PermissionDenied' error.+--+-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".+--+-- Since 1.4.14+csrfCheckMiddleware :: HandlerFor site res+                    -> HandlerFor site Bool -- ^ Whether or not to perform the CSRF check.+                    -> CI S8.ByteString -- ^ The header name to lookup the CSRF token from.+                    -> Text -- ^ The POST parameter name to lookup the CSRF token from.+                    -> HandlerFor site res+csrfCheckMiddleware handler shouldCheckFn headerName paramName = do+    shouldCheck <- shouldCheckFn+    when shouldCheck (checkCsrfHeaderOrParam headerName paramName)+    handler++-- | Calls 'csrfSetCookieMiddleware' with the 'defaultCsrfCookieName'.+--+-- The cookie's path is set to @/@, making it valid for your whole website.+--+-- Since 1.4.14+defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res+defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler++-- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'.+--+-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".+--+-- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.+--+-- Since 1.4.14+csrfSetCookieMiddleware :: HandlerFor site res -> SetCookie -> HandlerFor site res+csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler++-- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'.+--+-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".+--+-- You can chain this middleware together with other middleware like so:+--+-- @+-- 'yesodMiddleware' = 'defaultYesodMiddleware' . 'defaultCsrfMiddleware'+-- @+--+-- or:+--+-- @+-- 'yesodMiddleware' app = 'defaultYesodMiddleware' $ 'defaultCsrfMiddleware' $ app+-- @+--+-- Since 1.4.14+defaultCsrfMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res+defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware++-- | Convert a widget to a 'PageContent'.+widgetToPageContent :: Yesod site+                    => WidgetFor site ()+                    -> HandlerFor site (PageContent (Route site))+widgetToPageContent w = do+ jsAttrs <- jsAttributesHandler+ HandlerFor $ \hd -> do+  master <- unHandlerFor getYesod hd+  ref <- newIORef mempty+  unWidgetFor w WidgetData+    { wdRef = ref+    , wdHandler = hd+    }+  GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref+  let title = maybe mempty unTitle mTitle+      description = unDescription <$> mDescription+      scripts = runUniqueList scripts'+      stylesheets = runUniqueList stylesheets'++  flip unHandlerFor hd $ do+    render <- getUrlRenderParams+    let renderLoc x =+            case x of+                Nothing -> Nothing+                Just (Left s) -> Just s+                Just (Right (u, p)) -> Just $ render u p+    css <- forM (Map.toList style) $ \(mmedia, content) -> do+        let rendered = toLazyText $ content render+        x <- addStaticContent "css" "text/css; charset=utf-8"+           $ encodeUtf8 rendered+        return (mmedia,+            case x of+                Nothing -> Left $ preEscapedToMarkup rendered+                Just y -> Right $ either id (uncurry render) y)+    jsLoc <-+        case jscript of+            Nothing -> return Nothing+            Just s -> do+                x <- addStaticContent "js" "text/javascript; charset=utf-8"+                   $ encodeUtf8 $ renderJavascriptUrl render s+                return $ renderLoc x++    -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing+    -- the asynchronous loader means your page doesn't have to wait for all the js to load+    let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc+        regularScriptLoad = [hamlet|+            $newline never+            $forall s <- scripts+                ^{mkScriptTag s}+            $maybe j <- jscript+                $maybe s <- jsLoc+                    <script src="#{s}" *{jsAttrs}>+                $nothing+                    <script *{jsAttrs}>^{jelper j}+        |]++        headAll = [hamlet|+            $newline never+            \^{head'}+            $forall s <- stylesheets+                ^{mkLinkTag s}+            $forall s <- css+                $maybe t <- right $ snd s+                    $maybe media <- fst s+                        <link rel=stylesheet media=#{media} href=#{t}>+                    $nothing+                        <link rel=stylesheet href=#{t}>+                $maybe content <- left $ snd s+                    $maybe media <- fst s+                        <style media=#{media}>#{content}+                    $nothing+                        <style>#{content}+            $case jsLoader master+              $of BottomOfBody+              $of BottomOfHeadAsync asyncJsLoader+                  ^{asyncJsLoader asyncScripts mcomplete}+              $of BottomOfHeadBlocking+                  ^{regularScriptLoad}+        |]+    let bodyScript = [hamlet|+            $newline never+            ^{body}+            ^{regularScriptLoad}+        |]++    return $ PageContent title description headAll $+        case jsLoader master of+            BottomOfBody -> bodyScript+            _ -> body+  where+    renderLoc' render' (Local url) = render' url []+    renderLoc' _ (Remote s) = s++    addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)+    mkScriptTag (Script loc attrs) render' =+        foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()+    mkLinkTag (Stylesheet loc attrs) render' =+        foldl' addAttr TBH.link+            ( ("rel", "stylesheet")+            : ("href", renderLoc' render' loc)+            : attrs+            )++    runUniqueList :: Eq x => UniqueList x -> [x]+    runUniqueList (UniqueList x) = nub $ x []++-- | The default error handler for 'errorHandler'.+defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent+defaultErrorHandler NotFound = selectRep $ do+    provideRep $ defaultLayout $ do+        r <- waiRequest+        let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r+        defaultMessageWidget "Not Found" [hamlet|<p>#{path'}|]+    provideRep $ return $ object ["message" .= ("Not Found" :: Text)]+    provideRep $ return ("Not Found" :: Text)++-- For API requests.+-- For a user with a browser,+-- if you specify an authRoute the user will be redirected there and+-- this page will not be shown.+defaultErrorHandler NotAuthenticated = selectRep $ do+    provideRep $ defaultLayout $ defaultMessageWidget+        "Not logged in"+        [hamlet|<p style="display:none;">Set the authRoute and the user will be redirected there.|]++    provideRep $ do+        -- 401 *MUST* include a WWW-Authenticate header+        -- however, there is no standard to indicate a redirection+        --+        -- change this to Basic or Digest if you allow those forms of authentications+        addHeader "WWW-Authenticate" "RedirectJSON realm=\"application\", param=\"authentication_url\""++        -- The client will just use the authentication_url in the JSON+        site <- getYesod+        rend <- getUrlRender+        let apair u = ["authentication_url" .= rend u]+            content = maybe [] apair (authRoute site)+        return $ object $ ("message" .= ("Not logged in"::Text)):content+    provideRep $ return ("Not logged in" :: Text)++defaultErrorHandler (PermissionDenied msg) = selectRep $ do+    provideRep $ defaultLayout $ defaultMessageWidget+        "Permission Denied"+        [hamlet|<p>#{msg}|]+    provideRep $+        return $ object ["message" .= ("Permission Denied. " <> msg)]+    provideRep $ return $ "Permission Denied. " <> msg++defaultErrorHandler (InvalidArgs ia) = selectRep $ do+    provideRep $ defaultLayout $ defaultMessageWidget+        "Invalid Arguments"+        [hamlet|+            <ul>+                $forall msg <- ia+                    <li>#{msg}+        |]+    provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]+    provideRep $ return ("Invalid Arguments: " <> T.intercalate " " ia)++defaultErrorHandler (InternalError e) = do+    $logErrorS "yesod-core" e+    selectRep $ do+        provideRep $ defaultLayout $ defaultMessageWidget+            "Internal Server Error"+            [hamlet|<pre>#{e}|]+        provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]+        provideRep $ return $ "Internal Server Error: " <> e++defaultErrorHandler (BadMethod m) = selectRep $ do+    provideRep $ defaultLayout $ defaultMessageWidget+        "Method Not Supported"+        [hamlet|<p>Method <code>#{S8.unpack m}</code> not supported|]+    provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]+    provideRep $ return $ "Bad Method " <> TE.decodeUtf8With TEE.lenientDecode m++asyncHelper :: (url -> [x] -> Text)+         -> [Script url]+         -> Maybe (JavascriptUrl url)+         -> Maybe Text+         -> (Maybe (HtmlUrl url), [Text])+asyncHelper render scripts jscript jsLoc =+    (mcomplete, scripts'')+  where+    scripts' = map goScript scripts+    scripts'' =+        case jsLoc of+            Just s -> scripts' ++ [s]+            Nothing -> scripts'+    goScript (Script (Local url) _) = render url []+    goScript (Script (Remote s) _) = s+    mcomplete =+        case jsLoc of+            Just{} -> Nothing+            Nothing ->+                case jscript of+                    Nothing -> Nothing+                    Just j -> Just $ jelper j++-- | Default formatting for log messages. When you use+-- the template haskell logging functions for to log with information+-- about the source location, that information will be appended to+-- the end of the log. When you use the non-TH logging functions,+-- like 'logDebugN', this function does not include source+-- information. This currently works by checking to see if the+-- package name is the string \"\<unknown\>\". This is a hack,+-- but it removes some of the visual clutter from non-TH logs.+--+-- Since 1.4.10+formatLogMessage :: IO ZonedDate+                 -> Loc+                 -> LogSource+                 -> LogLevel+                 -> LogStr -- ^ message+                 -> IO LogStr+formatLogMessage getdate loc src level msg = do+    now <- getdate+    return $ mempty+        `mappend` toLogStr now+        `mappend` " ["+        `mappend` (case level of+            LevelOther t -> toLogStr t+            _ -> toLogStr $ drop 5 $ show level)+        `mappend` (if T.null src+            then mempty+            else "#" `mappend` toLogStr src)+        `mappend` "] "+        `mappend` msg+        `mappend` sourceSuffix+        `mappend` "\n"+    where+    sourceSuffix = if loc_package loc == "<unknown>" then "" else mempty+        `mappend` " @("+        `mappend` toLogStr (fileLocationToString loc)+        `mappend` ")"++-- | Customize the cookies used by the session backend.  You may+-- use this function on your definition of 'makeSessionBackend'.+--+-- For example, you could set the cookie domain so that it+-- would work across many subdomains:+--+-- @+-- makeSessionBackend site =+--     (fmap . fmap) (customizeSessionCookies addDomain) ...+--   where+--     addDomain cookie = cookie { 'setCookieDomain' = Just \".example.com\" }+-- @+--+-- Default: Do not customize anything ('id').+customizeSessionCookies :: (SetCookie -> SetCookie) -> (SessionBackend -> SessionBackend)+customizeSessionCookies customizeCookie backend = backend'+  where+    customizeHeader (AddCookie cookie) = AddCookie (customizeCookie cookie)+    customizeHeader other              = other+    customizeSaveSession = (fmap . fmap . fmap) customizeHeader+    backend' =+      backend {+        sbLoadSession = \req ->+          second customizeSaveSession `fmap` sbLoadSession backend req+      }+++defaultClientSessionBackend :: Int -- ^ minutes+                            -> FilePath -- ^ key file+                            -> IO SessionBackend+defaultClientSessionBackend minutes fp = do+  key <- CS.getKey fp+  (getCachedDate, _closeDateCacher) <- clientSessionDateCacher (minToSec minutes)+  return $ clientSessionBackend key getCachedDate++-- | Create a @SessionBackend@ which reads the session key from the named+-- environment variable.+--+-- This can be useful if:+--+-- 1. You can't rely on a persistent file system (e.g. Heroku)+-- 2. Your application is open source (e.g. you can't commit the key)+--+-- By keeping a consistent value in the environment variable, your users will+-- have consistent sessions without relying on the file system.+--+-- Note: A suitable value should only be obtained in one of two ways:+--+-- 1. Run this code without the variable set, a value will be generated and+--    printed on @/dev/stdout/@+-- 2. Use @clientsession-generate@+--+-- Since 1.4.5+envClientSessionBackend :: Int -- ^ minutes+                        -> String -- ^ environment variable name+                        -> IO SessionBackend+envClientSessionBackend minutes name = do+    key <- CS.getKeyEnv name+    (getCachedDate, _closeDateCacher) <- clientSessionDateCacher $ minToSec minutes+    return $ clientSessionBackend key getCachedDate++minToSec :: (Integral a, Num b) => a -> b+minToSec minutes = fromIntegral (minutes * 60)++jsToHtml :: Javascript -> Html+jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b++jelper :: JavascriptUrl url -> HtmlUrl url+jelper = fmap jsToHtml++left :: Either a b -> Maybe a+left (Left x) = Just x+left _ = Nothing++right :: Either a b -> Maybe b+right (Right x) = Just x+right _ = Nothing++clientSessionBackend :: CS.Key  -- ^ The encryption key+                     -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'+                     -> SessionBackend+clientSessionBackend key getCachedDate =+  SessionBackend {+    sbLoadSession = loadClientSession key getCachedDate "_SESSION"+  }++justSingleton :: a -> [Maybe a] -> a+justSingleton d = just . catMaybes+  where+    just [s] = s+    just _   = d++loadClientSession :: CS.Key+                  -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'+                  -> S8.ByteString -- ^ session name+                  -> W.Request+                  -> IO (SessionMap, SaveSession)+loadClientSession key getCachedDate sessionName req = load+  where+    load = do+      date <- getCachedDate+      return (sess date, save date)+    sess date = justSingleton Map.empty $ do+      raw <- [v | (k, v) <- W.requestHeaders req, k == "Cookie"]+      val <- [v | (k, v) <- parseCookies raw, k == sessionName]+      let host = "" -- fixme, properly lock sessions to client address+      return $ decodeClientSession key date host val+    save date sess' = do+      -- We should never cache the IV!  Be careful!+      iv <- liftIO CS.randomIV+      return [AddCookie defaultSetCookie+          { setCookieName = sessionName+          , setCookieValue = encodeClientSession key iv date host sess'+          , setCookiePath = Just "/"+          , setCookieExpires = Just (csdcExpires date)+          , setCookieDomain = Nothing+          , setCookieHttpOnly = True+          }]+        where+          host = "" -- fixme, properly lock sessions to client address++-- taken from file-location package+-- turn the TH Loc loaction information into a human readable string+-- leaving out the loc_end parameter+fileLocationToString :: Loc -> String+fileLocationToString loc =+    concat+      [ loc_package loc+      , ':' : loc_module loc+      , ' ' : loc_filename loc+      , ':' : line loc+      , ':' : char loc+      ]+  where+    line = show . fst . loc_start+    char = show . snd . loc_start++-- | Guess the approot based on request headers. For more information, see+-- "Network.Wai.Middleware.Approot"+--+-- In the case of headers being unavailable, it falls back to 'ApprootRelative'+--+-- Since 1.4.16+guessApproot :: Approot site+guessApproot = guessApprootOr ApprootRelative++-- | Guess the approot based on request headers, with fall back to the+-- specified 'AppRoot'.+--+-- Since 1.4.16+guessApprootOr :: Approot site -> Approot site+guessApprootOr fallback = ApprootRequest $ \master req ->+    case W.requestHeaderHost req of+        Nothing -> getApprootText fallback master req+        Just host ->+            (if Network.Wai.Request.appearsSecure req+                then "https://"+                else "http://")+            `T.append` TE.decodeUtf8With TEE.lenientDecode host++-- | Get the textual application root from an 'Approot' value.+--+-- Since 1.4.17+getApprootText :: Approot site -> site -> W.Request -> Text+getApprootText ar site req =+    case ar of+        ApprootRelative -> ""+        ApprootStatic t -> t+        ApprootMaster f -> f site+        ApprootRequest f -> f site req
+ src/Yesod/Core/Content.hs view
@@ -0,0 +1,322 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Yesod.Core.Content+    ( -- * Content+      Content (..)+    , emptyContent+    , ToContent (..)+    , ToFlushBuilder (..)+      -- * Mime types+      -- ** Data type+    , ContentType+    , typeHtml+    , typePlain+    , typeJson+    , typeXml+    , typeAtom+    , typeRss+    , typeJpeg+    , typePng+    , typeGif+    , typeSvg+    , typeJavascript+    , typeCss+    , typeFlv+    , typeOgv+    , typeOctet+      -- * Utilities+    , simpleContentType+    , contentTypeTypes+    , typedContentToSnippet+      -- * Evaluation strategy+    , DontFullyEvaluate (..)+      -- * Representations+    , TypedContent (..)+    , ToTypedContent (..)+    , HasContentType (..)+      -- ** Specific content types+    , RepHtml+    , RepJson (..)+    , RepPlain (..)+    , RepXml (..)+      -- ** Smart constructors+    , repJson+    , repPlain+    , repXml+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Builder as BB+import Data.Text.Lazy (Text, pack)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8Builder)+import qualified Data.Text.Lazy as TL++import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8)+import Text.Hamlet (Html)+import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)+import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput)+import Control.Monad (liftM)+import Control.Monad.Trans.Resource (ResourceT)+import qualified Data.Conduit.Internal as CI++import qualified Data.Aeson as J+import Data.Text.Lazy.Builder (toLazyText)+import Data.Void (Void, absurd)+import Yesod.Core.Types+import Text.Lucius (Css, renderCss)+import Text.Julius (Javascript, unJavascript)+import qualified Network.Wai.Parse as NWP+import qualified Data.Int as I+import Data.Word8 (_semicolon, _slash)+import Control.Arrow (second)+import Control.Exception (Exception)+import Data.Maybe++-- | Zero-length enumerator.+emptyContent :: Content+emptyContent = ContentBuilder mempty $ Just 0++-- | Anything which can be converted into 'Content'. Most of the time, you will+-- want to use the 'ContentBuilder' constructor. An easier approach will be to use+-- a pre-defined 'toContent' function, such as converting your data into a lazy+-- bytestring and then calling 'toContent' on that.+--+-- Please note that the built-in instances for lazy data structures ('String',+-- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include+-- the content length for the 'ContentBuilder' constructor.+class ToContent a where+    toContent :: a -> Content++instance ToContent Content where+    toContent = id+instance ToContent Builder where+    toContent = flip ContentBuilder Nothing+instance ToContent B.ByteString where+    toContent bs = ContentBuilder (byteString bs) $ Just $ B.length bs+instance ToContent L.ByteString where+    toContent = flip ContentBuilder Nothing . lazyByteString+instance ToContent T.Text where+    toContent = toContent . encodeUtf8Builder+instance ToContent Text where+    toContent = toContent . foldMap encodeUtf8Builder . TL.toChunks+instance ToContent String where+    toContent = toContent . stringUtf8+instance ToContent Html where+    toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing+instance ToContent () where+    toContent () = toContent B.empty+instance ToContent Void where+    toContent = absurd+instance ToContent (ContentType, Content) where+    toContent = snd+instance ToContent TypedContent where+    toContent (TypedContent _ c) = c+instance ToContent (JSONResponse a) where+    toContent (JSONResponse a) = toContent $ J.toEncoding a++instance ToContent Css where+    toContent = toContent . renderCss+instance ToContent Javascript where+    toContent = toContent . toLazyText . unJavascript++instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where+    toContent src = ContentSource $ CI.ConduitT (CI.mapOutput toFlushBuilder src >>=)++instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where+    toContent src = ContentSource $ mapOutput toFlushBuilder src+instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where+    toContent (CI.SealedConduitT src) = toContent src++-- | A class for all data which can be sent in a streaming response. Note that+-- for textual data, instances must use UTF-8 encoding.+--+-- Since 1.2.0+class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder+instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id+instance ToFlushBuilder Builder where toFlushBuilder = Chunk+instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap byteString+instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . byteString+instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap lazyByteString+instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . lazyByteString+instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap (foldMap encodeUtf8Builder . TL.toChunks)+instance ToFlushBuilder Text where toFlushBuilder = Chunk . foldMap encodeUtf8Builder . TL.toChunks+instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap encodeUtf8Builder+instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . encodeUtf8Builder+instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap stringUtf8+instance ToFlushBuilder String where toFlushBuilder = Chunk . stringUtf8+instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder+instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder++repJson :: ToContent a => a -> RepJson+repJson = RepJson . toContent++repPlain :: ToContent a => a -> RepPlain+repPlain = RepPlain . toContent++repXml :: ToContent a => a -> RepXml+repXml = RepXml . toContent++class ToTypedContent a => HasContentType a where+    getContentType :: Monad m => m a -> ContentType++instance HasContentType RepJson where+    getContentType _ = typeJson+deriving instance ToContent RepJson++instance HasContentType RepPlain where+    getContentType _ = typePlain+deriving instance ToContent RepPlain+instance HasContentType (JSONResponse a) where+    getContentType _ = typeJson++instance HasContentType RepXml where+    getContentType _ = typeXml+deriving instance ToContent RepXml+++typeHtml :: ContentType+typeHtml = "text/html; charset=utf-8"++typePlain :: ContentType+typePlain = "text/plain; charset=utf-8"++typeJson :: ContentType+typeJson = "application/json; charset=utf-8"++typeXml :: ContentType+typeXml = "text/xml"++typeAtom :: ContentType+typeAtom = "application/atom+xml"++typeRss :: ContentType+typeRss = "application/rss+xml"++typeJpeg :: ContentType+typeJpeg = "image/jpeg"++typePng :: ContentType+typePng = "image/png"++typeGif :: ContentType+typeGif = "image/gif"++typeSvg :: ContentType+typeSvg = "image/svg+xml"++typeJavascript :: ContentType+typeJavascript = "text/javascript; charset=utf-8"++typeCss :: ContentType+typeCss = "text/css; charset=utf-8"++typeFlv :: ContentType+typeFlv = "video/x-flv"++typeOgv :: ContentType+typeOgv = "video/ogg"++typeOctet :: ContentType+typeOctet = "application/octet-stream"++-- | Removes \"extra\" information at the end of a content type string. In+-- particular, removes everything after the semicolon, if present.+--+-- For example, \"text/html; charset=utf-8\" is commonly used to specify the+-- character encoding for HTML data. This function would return \"text/html\".+simpleContentType :: ContentType -> ContentType+simpleContentType = fst . B.break (== _semicolon)++-- | Give just the media types as a pair.+--+-- For example, \"text/html; charset=utf-8\" returns ("text", "html")+contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString)+contentTypeTypes = second tailEmpty . B.break (== _slash) . simpleContentType+  where+    tailEmpty x = if B.null x then "" else B.tail x++instance HasContentType a => HasContentType (DontFullyEvaluate a) where+    getContentType = getContentType . liftM unDontFullyEvaluate++instance ToContent a => ToContent (DontFullyEvaluate a) where+    toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a++instance ToContent J.Value where+    toContent = flip ContentBuilder Nothing+              . J.fromEncoding+              . J.toEncoding++instance ToContent J.Encoding where+    toContent = flip ContentBuilder Nothing . J.fromEncoding++instance HasContentType J.Value where+    getContentType _ = typeJson++instance HasContentType J.Encoding where+    getContentType _ = typeJson++instance HasContentType Html where+    getContentType _ = typeHtml++instance HasContentType Text where+    getContentType _ = typePlain++instance HasContentType T.Text where+    getContentType _ = typePlain++instance HasContentType Css where+    getContentType _ = typeCss++instance HasContentType Javascript where+    getContentType _ = typeJavascript++-- | Any type which can be converted to 'TypedContent'.+--+-- Since 1.2.0+class ToContent a => ToTypedContent a where+    toTypedContent :: a -> TypedContent++instance ToTypedContent TypedContent where+    toTypedContent = id+instance ToTypedContent () where+    toTypedContent () = TypedContent typePlain (toContent ())+instance ToTypedContent Void where+    toTypedContent = absurd+instance ToTypedContent (ContentType, Content) where+    toTypedContent (ct, content) = TypedContent ct content+instance ToTypedContent RepJson where+    toTypedContent (RepJson c) = TypedContent typeJson c+instance ToTypedContent RepPlain where+    toTypedContent (RepPlain c) = TypedContent typePlain c+instance ToTypedContent RepXml where+    toTypedContent (RepXml c) = TypedContent typeXml c+instance ToTypedContent J.Value where+    toTypedContent v = TypedContent typeJson (toContent v)+instance ToTypedContent J.Encoding where+    toTypedContent e = TypedContent typeJson (toContent e)+instance ToTypedContent Html where+    toTypedContent h = TypedContent typeHtml (toContent h)+instance ToTypedContent T.Text where+    toTypedContent t = TypedContent typePlain (toContent t)+instance ToTypedContent [Char] where+    toTypedContent = toTypedContent . pack+instance ToTypedContent Text where+    toTypedContent t = TypedContent typePlain (toContent t)+instance ToTypedContent (JSONResponse a) where+    toTypedContent c = TypedContent typeJson (toContent c)+instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where+    toTypedContent (DontFullyEvaluate a) =+        let TypedContent ct c = toTypedContent a+         in TypedContent ct (ContentDontEvaluate c)++instance ToTypedContent Css where+    toTypedContent = TypedContent typeCss . toContent+instance ToTypedContent Javascript where+    toTypedContent = TypedContent typeJavascript . toContent
+ src/Yesod/Core/Dispatch.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Yesod.Core.Dispatch+    ( -- * Quasi-quoted routing+      parseRoutes+    , parseRoutesNoCheck+    , parseRoutesFile+    , parseRoutesFileNoCheck+    , mkYesod+    , mkYesodOpts+    , mkYesodWith+      -- ** More fine-grained+    , mkYesodData+    , mkYesodDataOpts+    , mkYesodSubData+    , mkYesodSubDataOpts+    , mkYesodDispatch+    , mkYesodDispatchOpts+    , mkYesodSubDispatch+    , mkYesodSubDispatchInstance+    , mkYesodSubDispatchInstanceOpts+      -- *** Splitting a subsite's nested routes across modules+      --+      -- | These re-exports let a separately-compiled module generate a+      -- subsite's @YesodSubDispatchNested@ instance by hand (see the+      -- subsite-route-splitting recipe in @docs/split-route-compilation.md@).+      -- 'mkNestedSubDispatchInstance' takes the resources as+      -- @['ResourceTree' 'String']@ (the 'parseRoutes' quasi-quoter's output)+      -- and parses them internally, so no manual type-parsing is needed.++      -- | @since 1.7.0.0+    , mkNestedSubDispatchInstance+      -- | @since 1.7.0.0+    , TyArgs (..)+      -- *** Route generation options+    , RouteOpts+    , defaultOpts+    , setEqDerived+    , setShowDerived+    , setReadDerived+    , setCreateResources+    , setFocusOnNestedRoute+    , unsetFocusOnNestedRoute+    , setParameterizedSubroute+    , setNestedRouteFallthrough+      -- *** Helpers+    , defaultGen+    , getGetMaxExpires+      -- ** Path pieces+    , PathPiece (..)+    , PathMultiPiece (..)+    , Texts+      -- * Convert to WAI+    , toWaiApp+    , toWaiAppPlain+    , UrlToDispatch(..)+    , mkYesodRunnerEnv+    , toWaiAppPlainNested+    , toWaiAppYre+    , toWaiAppYreNested+    , warp+    , warpDebug+    , warpEnv+    , mkDefaultMiddlewares+    , defaultMiddlewaresNoLogging+      -- * Subsite nested dispatch+    , YesodSubDispatchNested (..)+      -- * WAI subsites+    , WaiSubsite (..)+    , WaiSubsiteWithAuth (..)+    ) where++import Prelude hiding (exp)+import Yesod.Core.Internal.TH+import Language.Haskell.TH.Syntax (qLocation)+import Data.Proxy+import Yesod.Routes.Class++import Web.PathPieces++import qualified Network.Wai as W++import Data.ByteString.Lazy.Char8 ()++import Data.Bits ((.|.), finiteBitSize, shiftL)+import Data.Text (Text)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+#if !MIN_VERSION_wai_extra(3,1,14)+import Data.Default (def)+#endif+import Yesod.Routes.Parse+import Yesod.Routes.TH (TyArgs (..))+import Yesod.Core.Types+import Yesod.Core.Class.Yesod+import Yesod.Core.Class.Dispatch+import Text.Read (readMaybe)+import System.Environment (getEnvironment)+import System.Entropy (getEntropy)+import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)+import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)+import Yesod.Core.Class.Dispatch.ToParentRoute++import Network.Wai.Middleware.Autohead+import Network.Wai.Middleware.AcceptOverride+import Network.Wai.Middleware.RequestLogger+import Network.Wai.Middleware.Gzip (+    gzip,+#if MIN_VERSION_wai_extra(3,1,14)+    defaultGzipSettings,+#endif+ )+import Network.Wai.Middleware.MethodOverride++import qualified Network.Wai.Handler.Warp+import System.Log.FastLogger+import Control.Monad.Logger+import Control.Monad (when)+import qualified Paths_yesod_core+import Data.Version (showVersion)++-- | Convert the given argument into a WAI application, executable with any WAI+-- handler. This function will provide no middlewares; if you want commonly+-- used middlewares, please use 'toWaiApp'.+toWaiAppPlain :: YesodDispatch site => site -> IO W.Application+toWaiAppPlain site = do+    yre <- mkYesodRunnerEnv site+    return $ toWaiAppYre yre++-- | Construct a 'YesodRunnerEnv' for a site, initializing its logger, session+-- backend, and other runtime state. This is the environment threaded through+-- dispatch; 'toWaiAppPlain' and friends build one for you, but it is exposed so+-- callers can construct and reuse a runner environment directly.+--+-- @since 1.7.0.0+mkYesodRunnerEnv :: Yesod site => site -> IO (YesodRunnerEnv site)+mkYesodRunnerEnv site = do+    logger <- makeLogger site+    sb <- makeSessionBackend site+    getMaxExpires <- getGetMaxExpires+    pure YesodRunnerEnv+        { yreLogger = logger+        , yreSite = site+        , yreSessionBackend = sb+        , yreGen = defaultGen+        , yreGetMaxExpires = getMaxExpires+        }++-- | Convert the given argument into a WAI application, executable with any WAI+-- handler. This function will provide no middlewares; if you want commonly+-- used middlewares, please use 'toWaiApp'.+--+-- This function allows you to create an 'Application' that only responds+-- to a subset of the 'site' routes. This is really only useful for writing+-- tests, but it does allow you to write tests that only depend on a subset+-- of the handlers instead of all handlers.+--+-- @since 1.7.0.0+toWaiAppPlainNested+    :: ( site ~ ParentSite route+        , Yesod site+        , YesodDispatchNested route+        , ToParentRoute route+        )+    => Proxy route+    -> ParentArgs route+    -> site+    -> IO W.Application+toWaiAppPlainNested proxy parentArgs site = do+    yre <- mkYesodRunnerEnv site+    return $ toWaiAppYreNested proxy parentArgs yre++-- | Generate a random number uniformly distributed in the full range+-- of 'Int'.+--+-- Note: Before 1.6.20, this generates pseudo-random number in an+-- unspecified range. The range size may not be a power of 2. Since+-- 1.6.20, this uses a secure entropy source and generates in the full+-- range of 'Int'.+--+-- @since 1.6.21.0+defaultGen :: IO Int+defaultGen = bsToInt <$> getEntropy bytes+  where+    bits = finiteBitSize (undefined :: Int)+    bytes = div (bits + 7) 8+    bsToInt = S.foldl' (\v i -> shiftL v 8 .|. fromIntegral i) 0++-- | Pure low level function to construct WAI application. Usefull+-- when you need not standard way to run your app, or want to embed it+-- inside another app.+--+-- @since 1.4.29+toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application+toWaiAppYre = toWaiAppYreNested (Proxy :: Proxy (Route site)) ()++-- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This+-- set may change with future releases, but currently covers:+--+-- * Logging+--+-- * GZIP compression+--+-- * Automatic HEAD method handling+--+-- * Request method override with the _method query string parameter+--+-- * Accept header override with the _accept query string parameter+toWaiApp :: YesodDispatch site => site -> IO W.Application+toWaiApp site = do+    logger <- makeLogger site+    toWaiAppLogger logger site++toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application+toWaiAppLogger logger site = do+    sb <- makeSessionBackend site+    getMaxExpires <- getGetMaxExpires+    let yre = YesodRunnerEnv+                { yreLogger = logger+                , yreSite = site+                , yreSessionBackend = sb+                , yreGen = defaultGen+                , yreGetMaxExpires = getMaxExpires+                }+    messageLoggerSource+        site+        logger+        $(qLocation >>= liftLoc)+        "yesod-core"+        LevelInfo+        (toLogStr ("Application launched" :: S.ByteString))+    middleware <- mkDefaultMiddlewares logger+    return $ middleware $ toWaiAppYre yre++-- | A convenience method to run an application using the Warp webserver on the+-- specified port. Automatically calls 'toWaiApp'. Provides a default set of+-- middlewares. This set may change at any point without a breaking version+-- number. Currently, it includes:+--+-- * Logging+--+-- * GZIP compression+--+-- * Automatic HEAD method handling+--+-- * Request method override with the _method query string parameter+--+-- * Accept header override with the _accept query string parameter+--+-- If you need more fine-grained control of middlewares, please use 'toWaiApp'+-- directly.+--+-- Since 1.2.0+warp :: YesodDispatch site => Int -> site -> IO ()+warp port site = do+    logger <- makeLogger site+    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings (+        Network.Wai.Handler.Warp.setPort port $+        Network.Wai.Handler.Warp.setServerName serverValue $+        Network.Wai.Handler.Warp.setOnException (\_ e ->+                when (shouldLog' e) $+                messageLoggerSource+                    site+                    logger+                    $(qLocation >>= liftLoc)+                    "yesod-core"+                    LevelError+                    (toLogStr $ "Exception from Warp: " ++ show e))+        Network.Wai.Handler.Warp.defaultSettings)+  where+    shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException++serverValue :: S8.ByteString+serverValue = S8.pack $ concat+    [ "Warp/"+    , Network.Wai.Handler.Warp.warpVersion+    , " + Yesod/"+    , showVersion Paths_yesod_core.version+    , " (core)"+    ]++-- | A default set of middlewares.+--+-- Since 1.2.0+mkDefaultMiddlewares :: Logger -> IO W.Middleware+mkDefaultMiddlewares logger = do+    logWare <- mkRequestLogger+#if MIN_VERSION_wai_extra(3,1,8)+        defaultRequestLoggerSettings+#else+        def+#endif+        { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger+        , outputFormat = Apache FromSocket+        }+    return $ logWare . defaultMiddlewaresNoLogging++-- | All of the default middlewares, excluding logging.+--+-- Since 1.2.12+defaultMiddlewaresNoLogging :: W.Middleware+defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip gzipSettings . methodOverride+  where+    gzipSettings =+#if MIN_VERSION_wai_extra(3,1,14)+        defaultGzipSettings+#else+        def+#endif++-- | Deprecated synonym for 'warp'.+warpDebug :: YesodDispatch site => Int -> site -> IO ()+warpDebug = warp+{-# DEPRECATED warpDebug "Please use warp instead" #-}++-- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It+-- reads port information from the PORT environment variable, as used by tools+-- such as Keter and the FP Complete School of Haskell.+--+-- Note that the exact behavior of this function may be modified slightly over+-- time to work correctly with external tools, without a change to the type+-- signature.+warpEnv :: YesodDispatch site => site -> IO ()+warpEnv site = do+    env <- getEnvironment+    case lookup "PORT" env of+        Nothing -> error "warpEnv: no PORT environment variable found"+        Just portS ->+            case readMaybe portS of+                Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS+                Just port -> warp port site++-- | Default constructor for 'yreGetMaxExpires' field. Low level+-- function for simple manual construction of 'YesodRunnerEnv'.+--+-- @since 1.4.29+getGetMaxExpires :: IO (IO Text)+getGetMaxExpires = mkAutoUpdate defaultUpdateSettings+  { updateAction = getCurrentMaxExpiresRFC1123+  , updateFreq = 24 * 60 * 60 * 1000000 -- Update once per day+  }
+ src/Yesod/Core/Handler.hs view
@@ -0,0 +1,1731 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++---------------------------------------------------------+--+-- Module        : Yesod.Handler+-- Copyright     : Michael Snoyman+-- License       : BSD3+--+-- Maintainer    : Michael Snoyman <michael@snoyman.com>+-- Stability     : stable+-- Portability   : portable+--+-- Define Handler stuff.+--+---------------------------------------------------------+module Yesod.Core.Handler+    ( -- * Handler monad+      HandlerT+    , HandlerFor+      -- ** Read information from handler+    , getYesod+    , getsYesod+    , getUrlRender+    , getUrlRenderParams+    , getPostParams+    , getCurrentRoute+    , getRequest+    , waiRequest+    , runRequestBody+    , rawRequestBody+      -- ** Request information+      -- *** Request datatype+    , RequestBodyContents+    , YesodRequest (..)+    , FileInfo+    , fileName+    , fileContentType+    , fileSource+    , fileSourceByteString+    , fileMove+      -- *** Convenience functions+    , languages+      -- *** Lookup parameters+    , lookupGetParam+    , lookupPostParam+    , lookupCookie+    , lookupFile+    , lookupHeader+      -- **** Lookup authentication data+    , lookupBasicAuth+    , lookupBearerAuth+      -- **** Multi-lookup+    , lookupGetParams+    , lookupPostParams+    , lookupCookies+    , lookupFiles+    , lookupHeaders+      -- * Responses+      -- ** Pure+    , respond+      -- ** Streaming+    , respondSource+    , sendChunk+    , sendFlush+    , sendChunkBS+    , sendChunkLBS+    , sendChunkText+    , sendChunkLazyText+    , sendChunkHtml+      -- ** Redirecting+    , RedirectUrl (..)+    , redirect+    , redirectWith+    , redirectToPost+    , Fragment(..)+      -- ** Errors+    , notFound+    , badMethod+    , notAuthenticated+    , permissionDenied+    , permissionDeniedI+    , invalidArgs+    , invalidArgsI+      -- ** Short-circuit responses+      -- $rollbackWarning+    , sendFile+    , sendFilePart+    , sendResponse+    , sendResponseStatus+      -- ** Type specific response with custom status+    , sendStatusJSON+    , sendResponseCreated+    , sendResponseNoContent+    , sendWaiResponse+    , sendWaiApplication+    , sendRawResponse+    , sendRawResponseNoConduit+    , notModified+      -- * Different representations+      -- $representations+    , selectRep+    , provideRep+    , provideRepType+    , ProvidedRep+      -- * Setting headers+    , setCookie+    , getExpires+    , deleteCookie+    , addHeader+    , setHeader+    , replaceOrAddHeader+    , setLanguage+    , addContentDispositionFileName+      -- ** Content caching and expiration+    , cacheSeconds+    , neverExpires+    , alreadyExpired+    , expiresAt+    , setEtag+    , setWeakEtag+      -- * Session+    , SessionMap+    , lookupSession+    , lookupSessionBS+    , getSession+    , setSession+    , setSessionBS+    , deleteSession+    , clearSession+      -- ** Ultimate destination+    , setUltDest+    , setUltDestCurrent+    , setUltDestReferer+    , redirectUltDest+    , clearUltDest+      -- ** Messages+    , addMessage+    , addMessageI+    , getMessages+    , setMessage+    , setMessageI+    , getMessage+      -- * Subsites+    , SubHandlerFor+    , getSubYesod+    , getRouteToParent+    , getSubCurrentRoute+      -- * Helpers for specific content+      -- ** Hamlet+    , hamletToRepHtml+    , giveUrlRenderer+    , withUrlRenderer+      -- ** Misc+    , newIdent+      -- * Lifting+    , handlerToIO+    , forkHandler+      -- * i18n+    , getMessageRender+      -- * Per-request caching+    , cached+    , cacheGet+    , cacheSet+    , cachedBy+    , cacheByGet+    , cacheBySet+      -- * AJAX CSRF protection++      -- $ajaxCSRFOverview++      -- ** Setting CSRF Cookies+    , setCsrfCookie+    , setCsrfCookieWithCookie+    , defaultCsrfCookieName+      -- ** Looking up CSRF Headers+    , checkCsrfHeaderNamed+    , hasValidCsrfHeaderNamed+    , defaultCsrfHeaderName+      -- ** Looking up CSRF POST Parameters+    , hasValidCsrfParamNamed+    , checkCsrfParamNamed+    , defaultCsrfParamName+      -- ** Checking CSRF Headers or POST Parameters+    , checkCsrfHeaderOrParam+    ) where++import           Data.Time                     (UTCTime, addUTCTime,+                                                getCurrentTime)+import           Yesod.Core.Internal.Request   (langKey, mkFileInfoFile,+                                                mkFileInfoLBS, mkFileInfoSource)+++import           Control.Applicative           ((<|>))+import qualified Data.CaseInsensitive          as CI+import           Control.Exception             (evaluate, SomeException, throwIO)+import           Control.Exception             (handle)++import           Control.Monad                 (void, liftM, unless)+import qualified Control.Monad.Trans.Writer    as Writer++import           UnliftIO                      (MonadIO, liftIO, MonadUnliftIO, withRunInIO)++import qualified Network.HTTP.Types            as H+import qualified Network.Wai                   as W+import           Network.Wai.Middleware.HttpAuth+    ( extractBasicAuth, extractBearerAuth )+import Control.Monad.Trans.Class (lift)++import           Data.Aeson                    (ToJSON(..))+import qualified Data.Text                     as T+import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8, decodeUtf8)+import           Data.Text.Encoding.Error      (lenientDecode)+import qualified Data.Text.Lazy                as TL+import           Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import           Text.Hamlet                   (Html, HtmlUrl, hamlet)++import qualified Data.ByteString               as S+import qualified Data.ByteString.Lazy          as L+import qualified Data.Map                      as Map+import qualified Data.HashMap.Strict           as HM++import           Data.ByteArray                (constEq)++import           Control.Arrow                 ((***))+import qualified Data.ByteString.Char8         as S8+import           Data.Monoid                   (Endo (..))+import           Data.Text                     (Text)+import qualified Network.Wai.Parse             as NWP+import           Text.Shakespeare.I18N         (RenderMessage (..))+import           Web.Cookie                    (SetCookie (..), defaultSetCookie)+import           Yesod.Core.Content            (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))+import           Yesod.Core.Internal.Util      (formatRFC1123)+import           Text.Blaze.Html               (preEscapedToHtml, toHtml)++import qualified Data.IORef                    as I+import           Data.Maybe                    (listToMaybe, mapMaybe)+import           Data.Typeable                 (Typeable)+import           Data.Kind                     (Type)+import           Web.PathPieces                (PathPiece(..))+import           Yesod.Core.Class.Handler+import           Yesod.Core.Types+import           Data.ByteString.Builder (Builder)+import           Data.CaseInsensitive (CI, original)+import qualified Data.Conduit.List as CL+import           Control.Monad.Trans.Resource  (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)+import qualified System.PosixCompat.Files as PC+import           Conduit ((.|), runConduit, sinkLazy)+import           Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void)+import qualified Yesod.Core.TypeCache as Cache+import qualified Data.Word8 as W8+import qualified Data.Foldable as Fold+import           Control.Monad.Logger (MonadLogger, logWarnS)+import Yesod.Routes.Class (WithParentArgs(..), ParentSite(..))+import Yesod.Core.Class.Dispatch.ToParentRoute (ToParentRoute(..))++type HandlerT site (m :: Type -> Type) = HandlerFor site+{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}++get :: MonadHandler m => m GHState+get = liftHandler $ HandlerFor $ I.readIORef . handlerState++put :: MonadHandler m => GHState -> m ()+put x = liftHandler $ HandlerFor $ flip I.writeIORef x . handlerState++modify :: MonadHandler m => (GHState -> GHState) -> m ()+modify f = liftHandler $ HandlerFor $ flip I.modifyIORef f . handlerState++tell :: MonadHandler m => Endo [Header] -> m ()+tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }++handlerError :: MonadHandler m => HandlerContents -> m a+handlerError = liftIO . throwIO++hcError :: MonadHandler m => ErrorResponse -> m a+hcError = handlerError . HCError++getRequest :: MonadHandler m => m YesodRequest+getRequest = liftHandler $ HandlerFor $ return . handlerRequest++runRequestBody :: MonadHandler m => m RequestBodyContents+runRequestBody = do+    HandlerData+        { handlerEnv = RunHandlerEnv {..}+        , handlerRequest = req+        } <- liftHandler $ HandlerFor return+    let len = W.requestBodyLength $ reqWaiRequest req+        upload = rheUpload len+    x <- get+    case ghsRBC x of+        Just rbc -> return rbc+        Nothing -> do+            rr <- waiRequest+            internalState <- liftResourceT getInternalState+            rbc <- liftIO $ rbHelper upload rr internalState+            put x { ghsRBC = Just rbc }+            return rbc++rbHelper :: FileUpload -> W.Request -> InternalState -> IO RequestBodyContents+rbHelper upload req internalState =+    case upload of+        FileUploadMemory s -> rbHelper' s mkFileInfoLBS req+        FileUploadDisk s -> rbHelper' (s internalState) mkFileInfoFile req+        FileUploadSource s -> rbHelper' s mkFileInfoSource req++rbHelper' :: NWP.BackEnd x+          -> (Text -> Text -> x -> FileInfo)+          -> W.Request+          -> IO ([(Text, Text)], [(Text, FileInfo)])+rbHelper' backend mkFI req =+    (map fix1 *** mapMaybe fix2) <$> NWP.parseRequestBody backend req+  where+    fix1 = go *** go+    fix2 (x, NWP.FileInfo a' b c)+        | S.null a = Nothing+        | otherwise = Just (go x, mkFI (go a) (go b) c)+      where+        a+            | S.length a' < 2 = a'+            | S8.head a' == '"' && S8.last a' == '"' = S.tail $ S.init a'+            | S8.head a' == '\'' && S8.last a' == '\'' = S.tail $ S.init a'+            | otherwise = a'+    go = decodeUtf8With lenientDecode++askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m) (HandlerSite m))+askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv++-- | Get the master site application argument.+getYesod :: MonadHandler m => m (HandlerSite m)+getYesod = rheSite <$> askHandlerEnv++-- | Get a specific component of the master site application argument.+--   Analogous to the 'gets' function for operating on 'StateT'.+getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a+getsYesod f = (f . rheSite) <$> askHandlerEnv++-- | Get the URL rendering function.+getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text)+getUrlRender = do+    x <- rheRender <$> askHandlerEnv+    return $ flip x []++-- | The URL rendering function with query-string parameters.+getUrlRenderParams+    :: MonadHandler m+    => m (Route (HandlerSite m) -> [(Text, Text)] -> Text)+getUrlRenderParams = rheRender <$> askHandlerEnv++-- | Get all the post parameters passed to the handler. To also get+-- the submitted files (if any), you have to use 'runRequestBody'+-- instead of this function.+--+-- @since 1.4.33+getPostParams+  :: MonadHandler m+  => m [(Text, Text)]+getPostParams = do+  reqBodyContent <- runRequestBody+  return $ fst reqBodyContent++-- | Get the route requested by the user. If this is a 404 response- where the+-- user requested an invalid route- this function will return 'Nothing'.+getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))+getCurrentRoute = rheRoute <$> askHandlerEnv++-- | Returns a function that runs 'HandlerFor' actions inside @IO@.+--+-- Sometimes you want to run an inner 'HandlerFor' action outside+-- the control flow of an HTTP request (on the outer 'HandlerFor'+-- action).  For example, you may want to spawn a new thread:+--+-- @+-- getFooR :: Handler RepHtml+-- getFooR = do+--   runInnerHandler <- handlerToIO+--   liftIO $ forkIO $ runInnerHandler $ do+--     /Code here runs inside HandlerFor but on a new thread./+--     /This is the inner HandlerFor./+--     ...+--   /Code here runs inside the request's control flow./+--   /This is the outer HandlerFor./+--   ...+-- @+--+-- Another use case for this function is creating a stream of+-- server-sent events using 'HandlerFor' actions (see+-- @yesod-eventsource@).+--+-- Most of the environment from the outer 'HandlerFor' is preserved+-- on the inner 'HandlerFor', however:+--+--  * The request body is cleared (otherwise it would be very+--  difficult to prevent huge memory leaks).+--+--  * The cache is cleared (see 'cached').+--+-- Changes to the response made inside the inner 'HandlerFor' are+-- ignored (e.g., session variables, cookies, response headers).+-- This allows the inner 'HandlerFor' to outlive the outer+-- 'HandlerFor' (e.g., on the @forkIO@ example above, a response+-- may be sent to the client without killing the new thread).+handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a)+handlerToIO =+  HandlerFor $ \oldHandlerData -> do+    -- Take just the bits we need from oldHandlerData.+    let newReq = oldReq { reqWaiRequest = newWaiReq }+          where+            oldReq    = handlerRequest oldHandlerData+            oldWaiReq = reqWaiRequest oldReq+#if MIN_VERSION_wai(3,2,4)+            newWaiReq =+                W.setRequestBodyChunks (return mempty) $+                    oldWaiReq { W.requestBodyLength = W.KnownLength 0 }+#else+            newWaiReq = oldWaiReq { W.requestBody = return mempty+                                  , W.requestBodyLength = W.KnownLength 0+                                  }+#endif+        oldEnv = handlerEnv oldHandlerData+    newState <- liftIO $ do+      oldState <- I.readIORef (handlerState oldHandlerData)+      return $ oldState { ghsRBC = Nothing+                        , ghsIdent = 1+                        , ghsCache = mempty+                        , ghsCacheBy = mempty+                        , ghsHeaders = mempty }++    -- xx From this point onwards, no references to oldHandlerData xx+    liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())++    -- Return HandlerFor running function.+    return $ \(HandlerFor f) ->+      liftIO $+      runResourceT $ withInternalState $ \resState -> do+        -- The state IORef needs to be created here, otherwise it+        -- will be shared by different invocations of this function.+        newStateIORef <- liftIO (I.newIORef newState)+        let newHandlerData =+              HandlerData+                { handlerRequest  = newReq+                , handlerEnv      = oldEnv+                , handlerState    = newStateIORef+                , handlerResource = resState+                }+        liftIO (f newHandlerData)++-- | forkIO for a Handler (run an action in the background)+--+-- Uses 'handlerToIO', liftResourceT, and resourceForkIO+-- for correctness and efficiency+--+-- @since 1.2.8+forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler+              -> HandlerFor site ()+              -> HandlerFor site ()+forkHandler onErr handler = do+    yesRunner <- handlerToIO+    void $ liftResourceT $ resourceForkIO $+      liftIO $ handle (yesRunner . onErr) (yesRunner handler)++-- | Redirect to the given route.+-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0+-- This is the appropriate choice for a get-following-post+-- technique, which should be the usual use case.+--+-- If you want direct control of the final status code, or need a different+-- status code, please use 'redirectWith'.+redirect :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+         => url -> m a+redirect url = do+    req <- waiRequest+    let status =+            if W.httpVersion req == H.http11+                then H.status303+                else H.status302+    redirectWith status url++-- | Redirect to the given URL with the specified status code.+redirectWith :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+             => H.Status+             -> url+             -> m a+redirectWith status url = do+    urlText <- toTextUrl url+    handlerError $ HCRedirect status urlText++ultDestKey :: Text+ultDestKey = "_ULT"++-- | Sets the ultimate destination variable to the given route.+--+-- An ultimate destination is stored in the user session and can be loaded+-- later by 'redirectUltDest'.+setUltDest :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+           => url+           -> m ()+setUltDest url = do+    urlText <- toTextUrl url+    setSession ultDestKey urlText++-- | Same as 'setUltDest', but uses the current page.+--+-- If this is a 404 handler, there is no current page, and then this call does+-- nothing.+setUltDestCurrent :: MonadHandler m => m ()+setUltDestCurrent = do+    route <- getCurrentRoute+    case route of+        Nothing -> return ()+        Just r -> do+            gets' <- reqGetParams <$> getRequest+            setUltDest (r, gets')++-- | Sets the ultimate destination to the referer request header, if present.+--+-- This function will not overwrite an existing ultdest.+setUltDestReferer :: MonadHandler m => m ()+setUltDestReferer = do+    mdest <- lookupSession ultDestKey+    maybe+        (waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)+        (const $ return ())+        mdest+  where+    setUltDestBS = setUltDest . T.pack . S8.unpack++-- | Redirect to the ultimate destination in the user's session. Clear the+-- value from the session.+--+-- The ultimate destination is set with 'setUltDest'.+--+-- This function uses 'redirect', and thus will perform a temporary redirect to+-- a GET request.+redirectUltDest :: (RedirectUrl (HandlerSite m) url, MonadHandler m)+                => url -- ^ default destination if nothing in session+                -> m a+redirectUltDest defaultDestination = do+    mdest <- lookupSession ultDestKey+    deleteSession ultDestKey+    maybe (redirect defaultDestination) redirect mdest++-- | Remove a previously set ultimate destination. See 'setUltDest'.+clearUltDest :: MonadHandler m => m ()+clearUltDest = deleteSession ultDestKey++msgKey :: Text+msgKey = "_MSG"++-- | Adds a status and message in the user's session.+--+-- See 'getMessages'.+--+-- @since 1.4.20+addMessage :: MonadHandler m+           => Text -- ^ status+           -> Html -- ^ message+           -> m ()+addMessage status msg = do+    val <- lookupSessionBS msgKey+    setSessionBS msgKey $ addMsg val+  where+    addMsg = maybe msg' (S.append msg' . S.cons W8._nul)+    msg' = S.append+        (encodeUtf8 status)+        (W8._nul `S.cons` L.toStrict (renderHtml msg))++-- | Adds a message in the user's session but uses RenderMessage to allow for i18n+--+-- See 'getMessages'.+--+-- @since 1.4.20+addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)+            => Text -> msg -> m ()+addMessageI status msg = do+    mr <- getMessageRender+    addMessage status $ toHtml $ mr msg++-- | Gets all messages in the user's session, and then clears the variable.+--+-- See 'addMessage'.+--+-- @since 1.4.20+getMessages :: MonadHandler m => m [(Text, Html)]+getMessages = do+    bs <- lookupSessionBS msgKey+    let ms = maybe [] enlist bs+    deleteSession msgKey+    return ms+  where+    enlist = pairup . S.split W8._nul+    pairup [] = []+    pairup [_] = []+    pairup (s:v:xs) = (decode s, preEscapedToHtml (decode v)) : pairup xs+    decode = decodeUtf8With lenientDecode++-- | Calls 'addMessage' with an empty status+setMessage :: MonadHandler m => Html -> m ()+setMessage = addMessage ""++-- | Calls 'addMessageI' with an empty status+setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)+            => msg -> m ()+setMessageI = addMessageI ""++-- | Gets just the last message in the user's session,+-- discards the rest and the status+getMessage :: MonadHandler m => m (Maybe Html)+getMessage = fmap (fmap snd . listToMaybe) getMessages++-- $rollbackWarning+--+-- Note that since short-circuiting is implemented by using exceptions,+-- using e.g. 'sendStatusJSON' inside a runDB block+-- will result in the database actions getting rolled back:+--+-- @+-- runDB $ do+--   userId <- insert $ User "username" "email@example.com"+--   postId <- insert $ BlogPost "title" "hi there!"+--     /The previous two inserts will be rolled back./+--   sendStatusJSON Status.status200 ()+-- @++-- | Bypass remaining handler code and output the given file.+--+-- For some backends, this is more efficient than reading in the file to+-- memory, since they can optimize file sending via a system call to sendfile.+sendFile :: MonadHandler m => ContentType -> FilePath -> m a+sendFile ct fp = handlerError $ HCSendFile ct fp Nothing++-- | Same as 'sendFile', but only sends part of a file.+sendFilePart :: MonadHandler m+             => ContentType+             -> FilePath+             -> Integer -- ^ offset+             -> Integer -- ^ count+             -> m a+sendFilePart ct fp off count = do+    fs <- liftIO $ PC.getFileStatus fp+    handlerError $ HCSendFile ct fp $ Just W.FilePart+        { W.filePartOffset = off+        , W.filePartByteCount = count+        , W.filePartFileSize = fromIntegral $ PC.fileSize fs+        }++-- | Bypass remaining handler code and output the given content with a 200+-- status code.+sendResponse :: (MonadHandler m, ToTypedContent c) => c -> m a+sendResponse = handlerError . HCContent H.status200 . toTypedContent++-- | Bypass remaining handler code and output the given content with the given+-- status code.+sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a+sendResponseStatus s = handlerError . HCContent s . toTypedContent++-- | Bypass remaining handler code and output the given JSON with the given+-- status code.+--+-- @since 1.4.18+sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a+sendStatusJSON s v = sendResponseStatus s (toEncoding v)++-- | Send a 201 "Created" response with the given route as the Location+-- response header.+sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a+sendResponseCreated url = do+    r <- getUrlRender+    handlerError $ HCCreated $ r url++-- | Bypass remaining handler code and output no content with a 204 status code.+--+-- @since 1.6.9+sendResponseNoContent :: MonadHandler m => m a+sendResponseNoContent = sendWaiResponse $ W.responseBuilder H.status204 [] mempty++-- | Send a 'W.Response'. Please note: this function is rarely+-- necessary, and will /disregard/ any changes to response headers and session+-- that you have already specified. This function short-circuits. It should be+-- considered only for very specific needs. If you are not sure if you need it,+-- you don't.+sendWaiResponse :: MonadHandler m => W.Response -> m b+sendWaiResponse = handlerError . HCWai++-- | Switch over to handling the current request with a WAI @Application@.+--+-- @since 1.2.17+sendWaiApplication :: MonadHandler m => W.Application -> m b+sendWaiApplication = handlerError . HCWaiApp++-- | Send a raw response without conduit. This is used for cases such as+-- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw+-- responses (e.g., Warp).+--+-- @since 1.2.16+sendRawResponseNoConduit+    :: (MonadHandler m, MonadUnliftIO m)+    => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())+    -> m a+sendRawResponseNoConduit raw = withRunInIO $ \runInIO ->+    liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback+    $ \src sink -> void $ runInIO (raw src sink)+  where+    fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]+        "sendRawResponse: backend does not support raw responses"++-- | Send a raw response. This is used for cases such as WebSockets. Requires+-- WAI 2.1 or later, and a web server which supports raw responses (e.g.,+-- Warp).+--+-- @since 1.2.7+sendRawResponse+  :: (MonadHandler m, MonadUnliftIO m)+  => (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ())+  -> m a+sendRawResponse raw = withRunInIO $ \runInIO ->+    liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback+    $ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink)+  where+    fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]+        "sendRawResponse: backend does not support raw responses"+    src' src = do+        bs <- liftIO src+        unless (S.null bs) $ do+            yield bs+            src' src++-- | Send a 304 not modified response immediately. This is a short-circuiting+-- action.+--+-- @since 1.4.4+notModified :: MonadHandler m => m a+notModified = sendWaiResponse $ W.responseBuilder H.status304 [] mempty++-- | Return a 404 not found page. Also denotes no handler available.+notFound :: MonadHandler m => m a+notFound = hcError NotFound++-- | Return a 405 method not supported page.+badMethod :: MonadHandler m => m a+badMethod = do+    w <- waiRequest+    hcError $ BadMethod $ W.requestMethod w++-- | Return a 401 status code+notAuthenticated :: MonadHandler m => m a+notAuthenticated = hcError NotAuthenticated++-- | Return a 403 permission denied page.+permissionDenied :: MonadHandler m => Text -> m a+permissionDenied = hcError . PermissionDenied++-- | Return a 403 permission denied page.+permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m)+                  => msg+                  -> m a+permissionDeniedI msg = do+    mr <- getMessageRender+    permissionDenied $ mr msg++-- | Return a 400 invalid arguments page.+invalidArgs :: MonadHandler m => [Text] -> m a+invalidArgs = hcError . InvalidArgs++-- | Return a 400 invalid arguments page.+invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a+invalidArgsI msg = do+    mr <- getMessageRender+    invalidArgs $ map mr msg++------- Headers+-- | Set the cookie on the client.++setCookie :: MonadHandler m => SetCookie -> m ()+setCookie sc = do+  addHeaderInternal (DeleteCookie name path)+  addHeaderInternal (AddCookie sc)+  where name = setCookieName sc+        path = maybe "/" id (setCookiePath sc)++-- | Helper function for setCookieExpires value+getExpires :: MonadIO m+           => Int -- ^ minutes+           -> m UTCTime+getExpires m = do+    now <- liftIO getCurrentTime+    return $ fromIntegral (m * 60) `addUTCTime` now+++-- | Unset the cookie on the client.+--+-- Note: although the value used for key and path is 'Text', you should only+-- use ASCII values to be HTTP compliant.+deleteCookie :: MonadHandler m+             => Text -- ^ key+             -> Text -- ^ path+             -> m ()+deleteCookie a = addHeaderInternal . DeleteCookie (encodeUtf8 a) . encodeUtf8+++-- | Set the language in the user session. Will show up in 'languages' on the+-- next request.+setLanguage :: MonadHandler m => Text -> m ()+setLanguage = setSession langKey++-- | Set attachment file name.+--+-- Allows Unicode characters by encoding to UTF-8.+-- Some modurn browser parse UTF-8 characters with out encoding setting.+-- But, for example IE9 can't parse UTF-8 characters.+-- This function use+-- <https://tools.ietf.org/html/rfc6266 RFC 6266>(<https://tools.ietf.org/html/rfc5987 RFC 5987>)+--+-- @since 1.6.4+addContentDispositionFileName :: MonadHandler m => T.Text -> m ()+addContentDispositionFileName fileName+    = addHeader "Content-Disposition" $ rfc6266Utf8FileName fileName++-- | <https://tools.ietf.org/html/rfc6266 RFC 6266> Unicode attachment filename.+--+-- > rfc6266Utf8FileName (Data.Text.pack "€")+-- "attachment; filename*=UTF-8''%E2%82%AC"+rfc6266Utf8FileName :: T.Text -> T.Text+rfc6266Utf8FileName fileName = "attachment; filename*=UTF-8''" `mappend` decodeUtf8 (H.urlEncode True (encodeUtf8 fileName))++-- | Set an arbitrary response header.+--+-- Note that, while the data type used here is 'Text', you must provide only+-- ASCII value to be HTTP compliant.+--+-- @since 1.2.0+addHeader :: MonadHandler m => Text -> Text -> m ()+addHeader a = addHeaderInternal . Header (CI.mk $ encodeUtf8 a) . encodeUtf8++-- | Deprecated synonym for addHeader.+setHeader :: MonadHandler m => Text -> Text -> m ()+setHeader = addHeader+{-# DEPRECATED setHeader "Please use addHeader instead" #-}++-- | Replace an existing header with a new value or add a new header+-- if not present.+--+-- Note that, while the data type used here is 'Text', you must provide only+-- ASCII value to be HTTP compliant.+--+-- @since 1.4.36+replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()+replaceOrAddHeader a b =+  modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)}+  where+    repHeader = Header (CI.mk $ encodeUtf8 a) (encodeUtf8 b)++    sameHeaderName :: Header -> Header -> Bool+    sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2+    sameHeaderName _ _ = False++    replaceIndividualHeader :: [Header] -> [Header]+    replaceIndividualHeader [] = [repHeader]+    replaceIndividualHeader xs = aux xs []+      where+        aux [] acc = acc ++ [repHeader]+        aux (x:xs') acc =+          if sameHeaderName repHeader x+            then acc +++                 [repHeader] +++                 (filter (\header -> not (sameHeaderName header repHeader)) xs')+            else aux xs' (acc ++ [x])++    replaceHeader :: Endo [Header] -> Endo [Header]+    replaceHeader endo =+      let allHeaders :: [Header] = appEndo endo []+      in Endo (\rest -> replaceIndividualHeader allHeaders ++ rest)++-- | Set the Cache-Control header to indicate this response should be cached+-- for the given number of seconds.+cacheSeconds :: MonadHandler m => Int -> m ()+cacheSeconds i = setHeader "Cache-Control" $ T.concat+    [ "max-age="+    , T.pack $ show i+    , ", public"+    ]++-- | Set the Expires header to some date in 2037. In other words, this content+-- is never (realistically) expired.+neverExpires :: MonadHandler m => m ()+neverExpires = do+    setHeader "Expires" . rheMaxExpires =<< askHandlerEnv+    cacheSeconds oneYear+  where+    oneYear :: Int+    oneYear = 60 * 60 * 24 * 365++-- | Set an Expires header in the past, meaning this content should not be+-- cached.+alreadyExpired :: MonadHandler m => m ()+alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"++-- | Set an Expires header to the given date.+expiresAt :: MonadHandler m => UTCTime -> m ()+expiresAt = setHeader "Expires" . formatRFC1123++data Etag+  = WeakEtag !S.ByteString+  -- ^ Prefixed by W/ and surrounded in quotes. Signifies that contents are+  -- semantically identical but make no guarantees about being bytewise identical.+  | StrongEtag !S.ByteString+  -- ^ Signifies that contents should be byte-for-byte identical if they match+  -- the provided ETag+  | InvalidEtag !S.ByteString+  -- ^ Anything else that ends up in a header that expects an ETag but doesn't+  -- properly follow the ETag format specified in RFC 7232, section 2.3+  deriving (Show, Eq)++-- | Check the if-none-match header and, if it matches the given value, return+-- a 304 not modified response. Otherwise, set the etag header to the given+-- value.+--+-- Note that it is the responsibility of the caller to ensure that the provided+-- value is a valid etag value, no sanity checking is performed by this+-- function.+--+-- @since 1.4.4+setEtag :: MonadHandler m => Text -> m ()+setEtag etag = do+    mmatch <- lookupHeader "if-none-match"+    let matches = maybe [] parseMatch mmatch+        baseTag = encodeUtf8 etag+        strongTag = StrongEtag baseTag+        badTag = InvalidEtag baseTag+    if any (\tag -> tag == strongTag || tag == badTag) matches+        then notModified+        else addHeader "etag" $ T.concat ["\"", etag, "\""]+++-- | Parse an if-none-match field according to the spec.+parseMatch :: S.ByteString -> [Etag]+parseMatch =+    map clean . S.split W8._comma+  where+    clean = classify . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace++    classify bs+        | S.length bs >= 2 && S.head bs == W8._quotedbl && S.last bs == W8._quotedbl+            = StrongEtag $ S.init $ S.tail bs+        | S.length bs >= 4 &&+          S.head bs == W8._W &&+          S.index bs 1 == W8._slash &&+          S.index bs 2 == W8._quotedbl &&+          S.last bs == W8._quotedbl+            = WeakEtag $ S.init $ S.drop 3 bs+        | otherwise = InvalidEtag bs++-- | Check the if-none-match header and, if it matches the given value, return+-- a 304 not modified response. Otherwise, set the etag header to the given+-- value.+--+-- A weak etag is only expected to be semantically identical to the prior content,+-- but doesn't have to be byte-for-byte identical. Therefore it can be useful for+-- dynamically generated content that may be difficult to perform bytewise hashing+-- upon.+--+-- Note that it is the responsibility of the caller to ensure that the provided+-- value is a valid etag value, no sanity checking is performed by this+-- function.+--+-- @since 1.4.37+setWeakEtag :: MonadHandler m => Text -> m ()+setWeakEtag etag = do+    mmatch <- lookupHeader "if-none-match"+    let matches = maybe [] parseMatch mmatch+    if WeakEtag (encodeUtf8 etag) `elem` matches+        then notModified+        else addHeader "etag" $ T.concat ["W/\"", etag, "\""]++-- | Set a variable in the user's session.+--+-- The session is handled by the clientsession package: it sets an encrypted+-- and hashed cookie on the client. This ensures that all data is secure and+-- not tampered with.+setSession :: MonadHandler m+           => Text -- ^ key+           -> Text -- ^ value+           -> m ()+setSession k = setSessionBS k . encodeUtf8++-- | Same as 'setSession', but uses binary data for the value.+setSessionBS :: MonadHandler m+             => Text+             -> S.ByteString+             -> m ()+setSessionBS k = modify . modSession . Map.insert k++-- | Unsets a session variable. See 'setSession'.+deleteSession :: MonadHandler m => Text -> m ()+deleteSession = modify . modSession . Map.delete++-- | Clear all session variables.+--+-- @since: 1.0.1+clearSession :: MonadHandler m => m ()+clearSession = modify $ \x -> x { ghsSession = Map.empty }++modSession :: (SessionMap -> SessionMap) -> GHState -> GHState+modSession f x = x { ghsSession = f $ ghsSession x }++-- | Internal use only, not to be confused with 'setHeader'.+addHeaderInternal :: MonadHandler m => Header -> m ()+addHeaderInternal = tell . Endo . (:)++-- | Some value which can be turned into a URL for redirects.+class RedirectUrl master a where+    -- | Converts the value to the URL and a list of query-string parameters.+    toTextUrl :: (MonadHandler m, HandlerSite m ~ master) => a -> m Text++instance RedirectUrl master Text where+    toTextUrl = return++instance RedirectUrl master String where+    toTextUrl = toTextUrl . T.pack++instance RedirectUrl master (Route master) where+    toTextUrl url = do+        r <- getUrlRender+        return $ r url++instance+    ( RedirectUrl master (Route master)+    , ParentSite url ~ master+    , ToParentRoute url+    )+  =>+    RedirectUrl master (WithParentArgs url)+  where+    toTextUrl (WithParentArgs args url) =+        toTextUrl (toParentRoute args url)++instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where+    toTextUrl (url, params) = do+        r <- getUrlRenderParams+        return $ r url params++instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where+    toTextUrl (url, params) = toTextUrl (url, Map.toList params)++-- | Add a fragment identifier to a route to be used when+-- redirecting.  For example:+--+-- > redirect (NewsfeedR :#: storyId)+--+-- @since 1.2.9.+data Fragment a b = a :#: b deriving Show++instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where+  toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a+++-- | Lookup for session data.+lookupSession :: MonadHandler m => Text -> m (Maybe Text)+lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS++-- | Lookup for session data in binary format.+lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString)+lookupSessionBS n = do+    m <- fmap ghsSession get+    return $ Map.lookup n m++-- | Get all session variables.+getSession :: MonadHandler m => m SessionMap+getSession = fmap ghsSession get++-- | Get a unique identifier.+newIdent :: MonadHandler m => m Text+newIdent = do+    x <- get+    let i' = ghsIdent x + 1+    put x { ghsIdent = i' }+    return $ T.pack $ "hident" ++ show i'++-- | Redirect to a POST resource.+--+-- This is not technically a redirect; instead, it returns an HTML page with a+-- POST form, and some Javascript to automatically submit the form. This can be+-- useful when you need to post a plain link somewhere that needs to cause+-- changes on the server.+redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+               => url+               -> m a+redirectToPost url = do+    urlText <- toTextUrl url+    req <- getRequest+    withUrlRenderer [hamlet|+$newline never+$doctype 5++<html>+    <head>+        <title>Redirecting...+    <body>+        <form id="form" method="post" action=#{urlText}>+            $maybe token <- reqToken req+                <input type=hidden name=#{defaultCsrfParamName} value=#{token}>+            <noscript>+                <p>Javascript has been disabled; please click on the button below to be redirected.+            <input type="submit" value="Continue">+        <script>+          window.onload = function() { document.getElementById('form').submit(); };+|] >>= sendResponse++-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.+hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html+hamletToRepHtml = withUrlRenderer+{-# DEPRECATED hamletToRepHtml "Use withUrlRenderer instead" #-}++-- | Deprecated synonym for 'withUrlRenderer'.+--+-- @since 1.2.0+giveUrlRenderer :: MonadHandler m+                => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)+                -> m output+giveUrlRenderer = withUrlRenderer+{-# DEPRECATED giveUrlRenderer "Use withUrlRenderer instead" #-}++-- | Provide a URL rendering function to the given function and return the+-- result. Useful for processing Shakespearean templates.+--+-- @since 1.2.20+withUrlRenderer :: MonadHandler m+                => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)+                -> m output+withUrlRenderer f = do+    render <- getUrlRenderParams+    return $ f render++-- | Get the request\'s 'W.Request' value.+waiRequest :: MonadHandler m => m W.Request+waiRequest = reqWaiRequest <$> getRequest++getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)+                 => m (message -> Text)+getMessageRender = do+    env <- askHandlerEnv+    l <- languages+    return $ renderMessage (rheSite env) l++-- | Use a per-request cache to avoid performing the same action multiple times.+-- Values are stored by their type, the result of typeOf from Typeable.+-- Therefore, you should use different newtype wrappers at each cache site.+--+-- For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth.+-- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts.+--+-- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>+--+-- @since 1.2.0+cached :: (MonadHandler m, Typeable a)+       => m a+       -> m a+cached action = do+    cache <- ghsCache <$> get+    eres <- Cache.cached cache action+    case eres of+      Right res -> return res+      Left (newCache, res) -> do+          gs <- get+          let merged = newCache `HM.union` ghsCache gs+          put $ gs { ghsCache = merged }+          return res++-- | Retrieves a value from the cache used by 'cached'.+--+-- @since 1.6.10+cacheGet :: (MonadHandler m, Typeable a)+         => m (Maybe a)+cacheGet = do+  cache <- ghsCache <$> get+  pure $ Cache.cacheGet cache++-- | Sets a value in the cache used by 'cached'.+--+-- @since 1.6.10+cacheSet :: (MonadHandler m, Typeable a)+         => a+         -> m ()+cacheSet value = do+  gs <- get+  let cache = ghsCache gs+      newCache = Cache.cacheSet value cache+  put $ gs { ghsCache = newCache }++-- | a per-request cache. just like 'cached'.+-- 'cached' can only cache a single value per type.+-- 'cachedBy' stores multiple values per type by usage of a ByteString key+--+-- 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user+-- 'cachedBy' is required if the action has parameters and can return multiple values per type.+-- You can turn those parameters into a ByteString cache key.+-- For example, caching a lookup of a Link by a token where multiple token lookups might be performed.+--+-- @since 1.4.0+cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a+cachedBy k action = do+    cache <- ghsCacheBy <$> get+    eres <- Cache.cachedBy cache k action+    case eres of+      Right res -> return res+      Left (newCache, res) -> do+          gs <- get+          let merged = newCache `HM.union` ghsCacheBy gs+          put $ gs { ghsCacheBy = merged }+          return res++-- | Retrieves a value from the cache used by 'cachedBy'.+--+-- @since 1.6.10+cacheByGet :: (MonadHandler m, Typeable a)+           => S.ByteString+           -> m (Maybe a)+cacheByGet key = do+  cache <- ghsCacheBy <$> get+  pure $ Cache.cacheByGet key cache++-- | Sets a value in the cache used by 'cachedBy'.+--+-- @since 1.6.10+cacheBySet :: (MonadHandler m, Typeable a)+           => S.ByteString+           -> a+           -> m ()+cacheBySet key value = do+  gs <- get+  let cache = ghsCacheBy gs+      newCache = Cache.cacheBySet key value cache+  put $ gs { ghsCacheBy = newCache }++-- | Get the list of supported languages supplied by the user.+--+-- Languages are determined based on the following (in descending order+-- of preference):+--+-- * The _LANG get parameter.+--+-- * The _LANG user session variable.+--+-- * The _LANG cookie.+--+-- * Accept-Language HTTP header.+--+-- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates.+-- If a matching language is not found the default language will be used.+--+-- This is handled by parseWaiRequest (not exposed).+--+-- __NOTE__: Before version @1.6.19.0@, this function prioritized the session+-- variable above all other sources.+--+languages :: MonadHandler m => m [Text]+languages = reqLangs <$> getRequest++lookup' :: Eq a => a -> [(a, b)] -> [b]+lookup' a = map snd . filter (\x -> a == fst x)++-- | Lookup a request header.+--+-- @since 1.2.2+lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString)+lookupHeader = fmap listToMaybe . lookupHeaders++-- | Lookup a request header.+--+-- @since 1.2.2+lookupHeaders :: MonadHandler m => CI S8.ByteString -> m [S8.ByteString]+lookupHeaders key = do+    req <- waiRequest+    return $ lookup' key $ W.requestHeaders req++-- | Lookup basic authentication data from __Authorization__ header of+-- request. Returns user name and password+--+-- @since 1.4.9+lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text))+lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization")+  where+    getBA bs = (decodeUtf8With lenientDecode *** decodeUtf8With lenientDecode)+               <$> extractBasicAuth bs++-- | Lookup bearer authentication datafrom __Authorization__ header of+-- request. Returns bearer token value+--+-- @since 1.4.9+lookupBearerAuth :: (MonadHandler m) => m (Maybe Text)+lookupBearerAuth = fmap (>>= getBR)+                   (lookupHeader "Authorization")+  where+    getBR bs = decodeUtf8With lenientDecode+               <$> extractBearerAuth bs+++-- | Lookup for GET parameters.+lookupGetParams :: MonadHandler m => Text -> m [Text]+lookupGetParams pn = do+    rr <- getRequest+    return $ lookup' pn $ reqGetParams rr++-- | Lookup for GET parameters.+lookupGetParam :: MonadHandler m => Text -> m (Maybe Text)+lookupGetParam = fmap listToMaybe . lookupGetParams++-- | Lookup for POST parameters.+lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text]+lookupPostParams pn = do+    (pp, _) <- runRequestBody+    return $ lookup' pn pp++lookupPostParam :: (MonadResource m, MonadHandler m)+                => Text+                -> m (Maybe Text)+lookupPostParam = fmap listToMaybe . lookupPostParams++-- | Lookup for POSTed files.+lookupFile :: MonadHandler m+           => Text+           -> m (Maybe FileInfo)+lookupFile = fmap listToMaybe . lookupFiles++-- | Lookup for POSTed files.+lookupFiles :: MonadHandler m+            => Text+            -> m [FileInfo]+lookupFiles pn = do+    (_, files) <- runRequestBody+    return $ lookup' pn files++-- | Lookup for cookie data.+lookupCookie :: MonadHandler m => Text -> m (Maybe Text)+lookupCookie = fmap listToMaybe . lookupCookies++-- | Lookup for cookie data.+lookupCookies :: MonadHandler m => Text -> m [Text]+lookupCookies pn = do+    rr <- getRequest+    return $ lookup' pn $ reqCookies rr++-- $representations+--+-- HTTP allows content negotation to determine what /representation/ of data+-- you would like to use. The most common example of this is providing both a+-- user-facing HTML page and an API facing JSON response from the same URL. The+-- means of achieving this is the Accept HTTP header, which provides a list of+-- content types the client will accept, sorted by preference.+--+-- By using 'selectRep' and 'provideRep', you can provide a number of different+-- representations, e.g.:+--+-- > selectRep $ do+-- >   provideRep produceHtmlOutput+-- >   provideRep produceJsonOutput+--+-- The first provided representation will be used if no matches are found.++-- | Select a representation to send to the client based on the representations+-- provided inside this do-block. Should be used together with 'provideRep'.+--+-- @since 1.2.0+selectRep :: MonadHandler m+          => Writer.Writer (Endo [ProvidedRep m]) ()+          -> m TypedContent+selectRep w = do+    -- the content types are already sorted by q values+    -- which have been stripped+    cts <- fmap reqAccept getRequest++    case mapMaybe tryAccept cts of+        [] ->+            case reps of+                [] -> sendResponseStatus H.status500 ("No reps provided to selectRep" :: Text)+                rep:_ -> returnRep rep+        rep:_ -> returnRep rep+  where+    returnRep (ProvidedRep ct mcontent) = fmap (TypedContent ct) mcontent++    reps = appEndo (Writer.execWriter w) []++    repMap = Map.unions $ map (\v@(ProvidedRep k _) -> Map.fromList+        [ (k, v)+        , (noSpace k, v)+        , (simpleContentType k, v)+        ]) reps++    -- match on the type for sub-type wildcards.+    -- If the accept is text/ * it should match a provided text/html+    mainTypeMap = Map.fromList $ reverse $ map+      (\v@(ProvidedRep ct _) -> (fst $ contentTypeTypes ct, v)) reps++    tryAccept ct =+        if subType == "*"+          then if mainType == "*"+                 then listToMaybe reps+                 else Map.lookup mainType mainTypeMap+          else lookupAccept ct+        where+          (mainType, subType) = contentTypeTypes ct++    lookupAccept ct = Map.lookup ct repMap <|>+                      Map.lookup (noSpace ct) repMap <|>+                      Map.lookup (simpleContentType ct) repMap++    -- Mime types such as "text/html; charset=foo" get converted to+    -- "text/html;charset=foo"+    noSpace = S8.filter (/= ' ')++-- | Internal representation of a single provided representation.+--+-- @since 1.2.0+data ProvidedRep m = ProvidedRep !ContentType !(m Content)++-- | Provide a single representation to be used, based on the request of the+-- client. Should be used together with 'selectRep'.+--+-- @since 1.2.0+provideRep :: (Monad m, HasContentType a)+           => m a+           -> Writer.Writer (Endo [ProvidedRep m]) ()+provideRep handler = provideRepType (getContentType handler) handler++-- | Same as 'provideRep', but instead of determining the content type from the+-- type of the value itself, you provide the content type separately. This can+-- be a convenience instead of creating newtype wrappers for uncommonly used+-- content types.+--+-- > provideRepType "application/x-special-format" "This is the content"+--+-- @since 1.2.0+provideRepType :: (Monad m, ToContent a)+               => ContentType+               -> m a+               -> Writer.Writer (Endo [ProvidedRep m]) ()+provideRepType ct handler =+    Writer.tell $ Endo (ProvidedRep ct (liftM toContent handler):)++-- | Stream in the raw request body without any parsing.+--+-- @since 1.2.0+rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m ()+rawRequestBody = do+    req <- lift waiRequest+    let loop = do+#if MIN_VERSION_wai(3,2,2)+            bs <- liftIO $ W.getRequestBodyChunk req+#else+            bs <- liftIO $ W.requestBody req+#endif+            unless (S.null bs) $ do+                yield bs+                loop+    loop++-- | Stream the data from the file. Since Yesod 1.2, this has been generalized+-- to work in any @MonadResource@.+fileSource :: MonadResource m => FileInfo -> ConduitT () S.ByteString m ()+fileSource = transPipe liftResourceT . fileSourceRaw++-- | Extract a strict `ByteString` body from a `FileInfo`.+--+-- This function will block while reading the file.+--+-- > do+-- >     fileByteString <- fileSourceByteString fileInfo+--+-- @since 1.6.5+fileSourceByteString :: MonadResource m => FileInfo -> m S.ByteString+fileSourceByteString fileInfo = runConduit (L.toStrict <$> (fileSource fileInfo .| sinkLazy))++-- | Provide a pure value for the response body.+--+-- > respond ct = return . TypedContent ct . toContent+--+-- @since 1.2.0+respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent+respond ct = return . TypedContent ct . toContent++-- | Use a @Source@ for the response body.+--+-- Note that, for ease of use, the underlying monad is a @HandlerFor@. This+-- implies that you can run any @HandlerFor@ action. However, since a streaming+-- response occurs after the response headers have already been sent, some+-- actions make no sense here. For example: short-circuit responses, setting+-- headers, changing status codes, etc.+--+-- @since 1.2.0+respondSource :: ContentType+              -> ConduitT () (Flush Builder) (HandlerFor site) ()+              -> HandlerFor site TypedContent+respondSource ctype src = HandlerFor $ \hd ->+    -- Note that this implementation relies on the fact that the ResourceT+    -- environment provided by the server is the same one used in HandlerFor.+    -- This is a safe assumption assuming the HandlerFor is run correctly.+    return $ TypedContent ctype $ ContentSource+           $ transPipe (lift . flip unHandlerFor hd) src++-- | In a streaming response, send a single chunk of data. This function works+-- on most datatypes, such as @ByteString@ and @Html@.+--+-- @since 1.2.0+sendChunk :: Monad m => ToFlushBuilder a => a -> ConduitT i (Flush Builder) m ()+sendChunk = yield . toFlushBuilder++-- | In a streaming response, send a flush command, causing all buffered data+-- to be immediately sent to the client.+--+-- @since 1.2.0+sendFlush :: Monad m => ConduitT i (Flush Builder) m ()+sendFlush = yield Flush++-- | Type-specialized version of 'sendChunk' for strict @ByteString@s.+--+-- @since 1.2.0+sendChunkBS :: Monad m => S.ByteString -> ConduitT i (Flush Builder) m ()+sendChunkBS = sendChunk++-- | Type-specialized version of 'sendChunk' for lazy @ByteString@s.+--+-- @since 1.2.0+sendChunkLBS :: Monad m => L.ByteString -> ConduitT i (Flush Builder) m ()+sendChunkLBS = sendChunk++-- | Type-specialized version of 'sendChunk' for strict @Text@s.+--+-- @since 1.2.0+sendChunkText :: Monad m => T.Text -> ConduitT i (Flush Builder) m ()+sendChunkText = sendChunk++-- | Type-specialized version of 'sendChunk' for lazy @Text@s.+--+-- @since 1.2.0+sendChunkLazyText :: Monad m => TL.Text -> ConduitT i (Flush Builder) m ()+sendChunkLazyText = sendChunk++-- | Type-specialized version of 'sendChunk' for @Html@s.+--+-- @since 1.2.0+sendChunkHtml :: Monad m => Html -> ConduitT i (Flush Builder) m ()+sendChunkHtml = sendChunk++-- $ajaxCSRFOverview+-- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in.+-- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs.+-- This is known as a <https://en.wikipedia.org/wiki/Cross-site_request_forgery Cross Site Request Forgery> (CSRF) attack.+--+-- To combat this attack, you need a way to verify that the request is valid.+-- This is achieved by generating a random string ("token"), storing it in your encrypted session so that the server can look it up (see 'reqToken'), and adding the token to HTTP requests made to your server.+-- When a request comes in, the token in the request is compared to the one from the encrypted session. If they match, you can be sure the request is valid.+--+-- Yesod implements this behavior in two ways:+--+-- (1) The yesod-form package <http://www.yesodweb.com/book/forms#forms_running_forms stores the CSRF token in a hidden field> in the form, then validates it with functions like 'Yesod.Form.Functions.runFormPost'.+--+-- (2) Yesod can store the CSRF token in a cookie which is accessible by Javascript. Requests made by Javascript can lookup this cookie and add it as a header to requests. The server then checks the token in the header against the one in the encrypted session.+--+-- The form-based approach has the advantage of working for users with Javascript disabled, while adding the token to the headers with Javascript allows things like submitting JSON or binary data in AJAX requests. Yesod supports checking for a CSRF token in either the POST parameters of the form ('checkCsrfParamNamed'), the headers ('checkCsrfHeaderNamed'), or both options ('checkCsrfHeaderOrParam').+--+-- The easiest way to check both sources is to add the 'Yesod.Core.defaultCsrfMiddleware' to your Yesod Middleware.+--+-- === Opting-out of CSRF checking for specific routes+--+-- (Note: this code is generic to opting out of any Yesod middleware)+--+-- @+-- 'yesodMiddleware' app = do+--   maybeRoute <- 'getCurrentRoute'+--   let dontCheckCsrf = case maybeRoute of+--                         Just HomeR                     -> True  -- Don't check HomeR+--                         Nothing                        -> True  -- Don't check for 404s+--                         _                              -> False -- Check other routes+--+--   'defaultYesodMiddleware' $ 'defaultCsrfSetCookieMiddleware' $ (if dontCheckCsrf then 'id' else 'defaultCsrfCheckMiddleware') $ app+-- @+--+-- This can also be implemented using the 'csrfCheckMiddleware' function.++-- | The default cookie name for the CSRF token ("XSRF-TOKEN").+--+-- @since 1.4.14+defaultCsrfCookieName :: S8.ByteString+defaultCsrfCookieName = "XSRF-TOKEN"++-- | Sets a cookie with a CSRF token, using 'defaultCsrfCookieName' for the cookie name.+--+-- The cookie's path is set to @/@, making it valid for your whole website.+--+-- @since 1.4.14+setCsrfCookie :: MonadHandler m => m ()+setCsrfCookie = setCsrfCookieWithCookie defaultSetCookie+  { setCookieName = defaultCsrfCookieName+  , setCookiePath = Just "/"+  }++-- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie.+--+-- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.+--+-- @since 1.4.14+setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m ()+setCsrfCookieWithCookie cookie  = do+    mCsrfToken <- reqToken <$> getRequest+    Fold.forM_ mCsrfToken (\token -> setCookie $ cookie { setCookieValue = encodeUtf8 token })++-- | The default header name for the CSRF token ("X-XSRF-TOKEN").+--+-- @since 1.4.14+defaultCsrfHeaderName :: CI S8.ByteString+defaultCsrfHeaderName = "X-XSRF-TOKEN"++-- | Takes a header name to lookup a CSRF token. If the value doesn't match the token stored in the session,+-- this function throws a 'PermissionDenied' error.+--+-- @since 1.4.14+checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m ()+checkCsrfHeaderNamed headerName = do+  (valid, mHeader) <- hasValidCsrfHeaderNamed' headerName+  unless valid (permissionDenied $ csrfErrorMessage [CSRFHeader (decodeUtf8 $ original headerName) mHeader])++-- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session.+--+-- @since 1.4.14+hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool+hasValidCsrfHeaderNamed headerName = fst <$> hasValidCsrfHeaderNamed' headerName++-- | Like 'hasValidCsrfHeaderNamed', but also returns the header value to be used in error messages.+hasValidCsrfHeaderNamed' :: MonadHandler m => CI S8.ByteString -> m (Bool, Maybe Text)+hasValidCsrfHeaderNamed' headerName = do+  mCsrfToken  <- reqToken <$> getRequest+  mXsrfHeader <- lookupHeader headerName++  return $ (validCsrf mCsrfToken mXsrfHeader, decodeUtf8 <$> mXsrfHeader)++-- CSRF Parameter checking++-- | The default parameter name for the CSRF token ("_token")+--+-- @since 1.4.14+defaultCsrfParamName :: Text+defaultCsrfParamName = "_token"++-- | Takes a POST parameter name to lookup a CSRF token. If the value doesn't match the token stored in the session,+-- this function throws a 'PermissionDenied' error.+--+-- @since 1.4.14+checkCsrfParamNamed :: MonadHandler m => Text -> m ()+checkCsrfParamNamed paramName = do+  (valid, mParam) <- hasValidCsrfParamNamed' paramName+  unless valid (permissionDenied $ csrfErrorMessage [CSRFParam paramName mParam])++-- | Takes a POST parameter name to lookup a CSRF token, and returns whether the value matches the token stored in the session.+--+-- @since 1.4.14+hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool+hasValidCsrfParamNamed paramName = fst <$> hasValidCsrfParamNamed' paramName++-- | Like 'hasValidCsrfParamNamed', but also returns the param value to be used in error messages.+hasValidCsrfParamNamed' :: MonadHandler m => Text -> m (Bool, Maybe Text)+hasValidCsrfParamNamed' paramName = do+  mCsrfToken  <- reqToken <$> getRequest+  mCsrfParam <- lookupPostParam paramName++  return $ (validCsrf mCsrfToken (encodeUtf8 <$> mCsrfParam), mCsrfParam)++-- | Checks that a valid CSRF token is present in either the request headers or POST parameters.+-- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error.+--+-- @since 1.4.14+checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m)+                       => CI S8.ByteString -- ^ The header name to lookup the CSRF token+                       -> Text -- ^ The POST parameter name to lookup the CSRF token+                       -> m ()+checkCsrfHeaderOrParam headerName paramName = do+  (validHeader, mHeader) <- hasValidCsrfHeaderNamed' headerName+  (validParam, mParam) <- hasValidCsrfParamNamed' paramName+  unless (validHeader || validParam) $ do+    let errorMessage = csrfErrorMessage $ [CSRFHeader (decodeUtf8 $ original headerName) mHeader, CSRFParam paramName mParam]+    $logWarnS "yesod-core" errorMessage+    permissionDenied errorMessage++validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool+-- It's important to use constant-time comparison (constEq) in order to avoid timing attacks.+validCsrf (Just token) (Just param) = encodeUtf8 token `constEq` param+validCsrf Nothing            _param = True+validCsrf (Just _token)     Nothing = False++data CSRFExpectation = CSRFHeader Text (Maybe Text) -- Key/Value+                     | CSRFParam Text (Maybe Text) -- Key/Value++csrfErrorMessage :: [CSRFExpectation]+                  -> Text -- ^ Error message+csrfErrorMessage expectedLocations = T.intercalate "\n"+  [ "A valid CSRF token wasn't present. Because the request could have been forged, it's been rejected altogether."+  , "If you're a developer of this site, these tips will help you debug the issue:"+  , "- Read the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection."+  , "- Check that your HTTP client is persisting cookies between requests, like a browser does."+  , "- By default, the CSRF token is sent to the client in a cookie named " `mappend` (decodeUtf8 defaultCsrfCookieName) `mappend` "."+  , "- The server is looking for the token in the following locations:\n" `mappend` T.intercalate "\n" (map csrfLocation expectedLocations)+  ]++  where csrfLocation expected = case expected of+          CSRFHeader k v -> T.intercalate " " ["  - An HTTP header named", k, (formatValue v)]+          CSRFParam k v -> T.intercalate " " ["  - A POST parameter named", k, (formatValue v)]++        formatValue :: Maybe Text -> Text+        formatValue maybeText = case maybeText of+          Nothing -> "(which is not currently set)"+          Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"]++getSubYesod :: MonadHandler m => m (SubHandlerSite m)+getSubYesod = liftSubHandler $ SubHandlerFor $ return . rheChild . handlerEnv++getRouteToParent :: MonadHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m))+getRouteToParent = liftSubHandler $ SubHandlerFor $ return . rheRouteToMaster . handlerEnv++getSubCurrentRoute :: MonadHandler m => m (Maybe (Route (SubHandlerSite m)))+getSubCurrentRoute = liftSubHandler $ SubHandlerFor $ return . rheRoute . handlerEnv
+ src/Yesod/Core/Internal.hs view
@@ -0,0 +1,8 @@+-- | Exposed mostly for testing. These functions provide an unstable API and+-- should not be relied upon.+module Yesod.Core.Internal+    ( module X+    ) where++import Yesod.Core.Internal.Request as X (randomString, parseWaiRequest)+import Yesod.Core.Internal.TH as X (mkYesodGeneral)
+ src/Yesod/Core/Internal/LiteApp.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies #-}++module Yesod.Core.Internal.LiteApp where++import Yesod.Routes.Class+import Yesod.Core.Class.Yesod+import Yesod.Core.Class.Dispatch+import Yesod.Core.Types+import Yesod.Core.Content+import Data.Text (Text)+import Web.PathPieces+import Network.Wai+import Yesod.Core.Handler+import Yesod.Core.Internal.Run+import Network.HTTP.Types (Method)+import Data.Maybe (fromMaybe)+import Control.Applicative ((<|>))+import Control.Monad.Trans.Writer++newtype LiteApp = LiteApp+    { unLiteApp :: Method -> [Text] -> Maybe (LiteHandler TypedContent)+    }++instance Yesod LiteApp++instance YesodDispatch LiteApp where+    yesodDispatch yre req =+        yesodRunner+            (fromMaybe notFound $ f (requestMethod req) (pathInfo req))+            yre+            (Just $ LiteAppRoute $ pathInfo req)+            req+      where+        LiteApp f = yreSite yre++instance RenderRoute LiteApp where+    data Route LiteApp = LiteAppRoute [Text]+        deriving (Show, Eq, Read, Ord)+    renderRoute (LiteAppRoute x) = (x, [])+instance ParseRoute LiteApp where+    parseRoute (x, _) = Just $ LiteAppRoute x++instance Semigroup LiteApp where+    LiteApp x <> LiteApp y = LiteApp $ \m ps -> x m ps <|> y m ps++instance Monoid LiteApp where+    mempty = LiteApp $ \_ _ -> Nothing++type LiteHandler = HandlerFor LiteApp+type LiteWidget = WidgetFor LiteApp++liteApp :: Writer LiteApp () -> LiteApp+liteApp = execWriter++dispatchTo :: ToTypedContent a => LiteHandler a -> Writer LiteApp ()+dispatchTo handler = tell $ LiteApp $ \_ ps ->+    if null ps+        then Just $ fmap toTypedContent handler+        else Nothing++onMethod :: Method -> Writer LiteApp () -> Writer LiteApp ()+onMethod method f = tell $ LiteApp $ \m ps ->+    if method == m+        then unLiteApp (liteApp f) m ps+        else Nothing++onStatic :: Text -> Writer LiteApp () -> Writer LiteApp ()+onStatic p0 f = tell $ LiteApp $ \m ps0 ->+    case ps0 of+        p:ps | p == p0 -> unLiteApp (liteApp f) m ps+        _ -> Nothing++withDynamic :: PathPiece p => (p -> Writer LiteApp ()) -> Writer LiteApp ()+withDynamic f = tell $ LiteApp $ \m ps0 ->+    case ps0 of+        p:ps | Just v <- fromPathPiece p -> unLiteApp (liteApp $ f v) m ps+        _ -> Nothing++withDynamicMulti :: PathMultiPiece ps => (ps -> Writer LiteApp ()) -> Writer LiteApp ()+withDynamicMulti f = tell $ LiteApp $ \m ps ->+    case fromPathMultiPiece ps of+        Nothing -> Nothing+        Just v -> unLiteApp (liteApp $ f v) m []
+ src/Yesod/Core/Internal/Request.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Core.Internal.Request+    ( parseWaiRequest+    , RequestBodyContents+    , FileInfo+    , fileName+    , fileContentType+    , fileMove+    , mkFileInfoLBS+    , mkFileInfoFile+    , mkFileInfoSource+    , FileUpload (..)+    , tooLargeResponse+    , tokenKey+    , langKey+    , textQueryString+    -- The below are exported for testing.+    , randomString+    ) where++import Data.String (IsString)+import Control.Arrow (second)+import qualified Network.Wai.Parse as NWP+import qualified Network.Wai as W+import Web.Cookie (parseCookiesText)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as LS8+import Data.Text (Text, pack)+import Network.HTTP.Types (queryToQueryText, Status (Status))+import Data.Maybe (fromMaybe, catMaybes)+import qualified Data.ByteString.Lazy as L+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With, decodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import Conduit+import Data.Word (Word8, Word64)+import Control.Exception (throwIO)+import Control.Monad ((<=<), liftM)+import Yesod.Core.Types+import qualified Data.Map as Map+import Data.IORef+import qualified Data.Vector.Storable as V+import Data.ByteString.Internal (ByteString (PS))+import qualified Data.Word8 as Word8++-- | Impose a limit on the size of the request body.+limitRequestBody :: Word64 -> W.Request -> IO W.Request+limitRequestBody maxLen req = do+    ref <- newIORef maxLen+    let bd = do+#if MIN_VERSION_wai(3,2,2)+            bs <- W.getRequestBodyChunk req+#else+            bs <- W.requestBody req+#endif+            remaining <- readIORef ref+            let len = fromIntegral $ S8.length bs+                remaining' = remaining - len+            if remaining < len+                then throwIO $ HCWai $ tooLargeResponse maxLen len+                else do+                    writeIORef ref remaining'+                    return bs+#if MIN_VERSION_wai(3,2,4)+    return $ W.setRequestBodyChunks bd req+#else+    return req { W.requestBody = bd }+#endif++tooLargeResponse :: Word64 -> Word64 -> W.Response+tooLargeResponse maxLen bodyLen = W.responseLBS+    (Status 413 "Too Large")+    [("Content-Type", "text/plain")]+    (L.concat+        [ "Request body too large to be processed. The maximum size is "+        , (LS8.pack (show maxLen))+        , " bytes; your request body was "+        , (LS8.pack (show bodyLen))+        , " bytes. If you're the developer of this site, you can configure the maximum length with the `maximumContentLength` or `maximumContentLengthIO` function on the Yesod typeclass."+        ])++parseWaiRequest :: W.Request+                -> SessionMap+                -> Bool+                -> Maybe Word64 -- ^ max body size+                -> Either (IO YesodRequest) (IO Int -> IO YesodRequest)+parseWaiRequest env session useToken mmaxBodySize =+    -- In most cases, we won't need to generate any random values. Therefore,+    -- we split our results: if we need a random generator, return a Right+    -- value, otherwise return a Left and avoid the relatively costly generator+    -- acquisition.+    case etoken of+        Left token -> Left $ mkRequest token+        Right mkToken -> Right $ mkRequest <=< mkToken+  where+    mkRequest token' = do+        envLimited <- maybe return limitRequestBody mmaxBodySize env+        return YesodRequest+            { reqGetParams  = gets+            , reqCookies    = cookies+            , reqWaiRequest = envLimited+            , reqLangs      = langs''+            , reqToken      = token'+            , reqSession    = if useToken+                                then Map.delete tokenKey session+                                else session+            , reqAccept     = httpAccept env+            }+    gets = textQueryString env+    reqCookie = lookup "Cookie" $ W.requestHeaders env+    cookies = maybe [] parseCookiesText reqCookie+    acceptLang = lookup "Accept-Language" $ W.requestHeaders env+    langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang++    lookupText k = fmap (decodeUtf8With lenientDecode) . Map.lookup k++    -- The language preferences are prioritized as follows:+    langs' = catMaybes [ lookup langKey gets -- Query _LANG+                       , lookup langKey cookies     -- Cookie _LANG+                       , lookupText langKey session -- Session _LANG+                       ] ++ langs                    -- Accept-Language(s)++    -- Github issue #195. We want to add an extra two-letter version of any+    -- language in the list.+    langs'' = addTwoLetters (id, Set.empty) langs'++    -- If sessions are disabled tokens should not be used (any+    -- tokenKey present in the session is ignored). If sessions+    -- are enabled and a session has no tokenKey a new one is+    -- generated.+    etoken+        | useToken =+            case Map.lookup tokenKey session of+                -- Already have a token, use it.+                Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs+                -- Don't have a token, get a random generator and make a new one.+                Nothing -> Right $ fmap Just . randomString 40+        | otherwise = Left Nothing++textQueryString :: W.Request -> [(Text, Text)]+textQueryString = map (second $ fromMaybe "") . queryToQueryText . W.queryString++-- | Get the list of accepted content types from the WAI Request\'s Accept+-- header.+--+-- Since 1.2.0+httpAccept :: W.Request -> [ContentType]+httpAccept = NWP.parseHttpAccept+           . fromMaybe S8.empty+           . lookup "Accept"+           . W.requestHeaders++addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]+addTwoLetters (toAdd, exist) [] =+    filter (`Set.notMember` exist) $ toAdd []+addTwoLetters (toAdd, exist) (l:ls) =+    l : addTwoLetters (toAdd', exist') ls+  where+    (toAdd', exist')+        | T.length l > 2 = (toAdd . (T.take 2 l:), exist)+        | otherwise = (toAdd, Set.insert l exist)++-- | Generate a random String of alphanumerical characters+-- (a-z, A-Z, and 0-9) of the given length using the given+-- random number generator.+randomString :: Monad m => Int -> m Int -> m Text+randomString len gen =+    liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar+  where+    asciiChar =+      let loop = do+            x <- gen+            let y = fromIntegral $ x `mod` 64+            case () of+              ()+                | y < 26 -> return $ y + Word8._A+                | y < 52 -> return $ y + Word8._a - 26+                | y < 62 -> return $ y + Word8._0 - 52+                | otherwise -> loop+       in loop++fromByteVector :: V.Vector Word8 -> ByteString+fromByteVector v =+    PS fptr offset idx+  where+    (fptr, offset, idx) = V.unsafeToForeignPtr v+{-# INLINE fromByteVector #-}++mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo+mkFileInfoLBS name ct lbs =+    FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs)++mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo+mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runConduitRes $ sourceFile fp .| sinkFile dst)++mkFileInfoSource :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo+mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst)++tokenKey :: IsString a => a+tokenKey = "_TOKEN"++langKey :: IsString a => a+langKey = "_LANG"
+ src/Yesod/Core/Internal/Response.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Core.Internal.Response where++import           Data.ByteString              (ByteString)+import qualified Data.ByteString              as S+import qualified Data.ByteString.Char8        as S8+import qualified Data.ByteString.Lazy         as BL+import           Data.CaseInsensitive         (CI)+import           Network.Wai+import           Control.Monad                (mplus)+import           Control.Monad.Trans.Resource (runInternalState, InternalState)+import           Network.Wai.Internal+import           Web.Cookie                   (renderSetCookie)+import           Yesod.Core.Content+import           Yesod.Core.Types+import qualified Network.HTTP.Types           as H+import qualified Data.Text                    as T+import           Control.Exception            (SomeException, handle)+import           Data.ByteString.Builder      (lazyByteString, toLazyByteString)+import qualified Data.ByteString.Lazy         as L+import qualified Data.Map                     as Map+import           Yesod.Core.Internal.Request  (tokenKey)+import           Data.Text.Encoding           (encodeUtf8)+import           Conduit++yarToResponse :: YesodResponse+              -> (SessionMap -> IO [Header]) -- ^ save session+              -> YesodRequest+              -> Request+              -> InternalState+              -> (Response -> IO ResponseReceived)+              -> IO ResponseReceived+yarToResponse (YRWai a) _ _ _ _ sendResponse = sendResponse a+yarToResponse (YRWaiApp app) _ _ req _ sendResponse = app req sendResponse+yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse = do+    extraHeaders <- do+        let nsToken = maybe+                newSess+                (\n -> Map.insert tokenKey (encodeUtf8 n) newSess)+                (reqToken yreq)+        sessionHeaders <- saveSession nsToken+        return $ ("Content-Type", ct) : map headerToPair sessionHeaders+    let finalHeaders = extraHeaders ++ map headerToPair hs+        finalHeaders' len = ("Content-Length", S8.pack $ show len)+                          : finalHeaders++    let go (ContentBuilder b mlen) = do+            let hs' = maybe finalHeaders finalHeaders' mlen+            sendResponse $ ResponseBuilder s hs' b+        go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p+        go (ContentSource body) = sendResponse $ responseStream s finalHeaders+            $ \sendChunk flush -> runConduit $+                transPipe (`runInternalState` is) body+                .| mapM_C (\mchunk ->+                    case mchunk of+                        Flush -> flush+                        Chunk builder -> sendChunk builder)+        go (ContentDontEvaluate c') = go c'+    go c+  where+    s+        | s' == defaultStatus = H.status200+        | otherwise = s'++-- | Indicates that the user provided no specific status code to be used, and+-- therefore the default status code should be used. For normal responses, this+-- would be a 200 response, whereas for error responses this would be an+-- appropriate status code.+--+-- For more information on motivation for this, see:+--+-- https://groups.google.com/d/msg/yesodweb/vHDBzyu28TM/bezCvviWp4sJ+--+-- Since 1.2.3.1+defaultStatus :: H.Status+defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"++-- | Convert Header to a key/value pair.+headerToPair :: Header+             -> (CI ByteString, ByteString)+headerToPair (AddCookie sc) =+    ("Set-Cookie", BL.toStrict $ toLazyByteString $ renderSetCookie sc)+headerToPair (DeleteCookie key path) =+    ( "Set-Cookie"+    , S.concat+        [ key+        , "=; path="+        , path+        , "; expires=Thu, 01-Jan-1970 00:00:00 GMT"+        ]+    )+headerToPair (Header key value) = (key, value)++evaluateContent :: Content -> IO (Either ErrorResponse Content)+evaluateContent (ContentBuilder b mlen) = handle f $ do+    let lbs = toLazyByteString b+        len = L.length lbs+        mlen' = mlen `mplus` Just (fromIntegral len)+    len `seq` return (Right $ ContentBuilder (lazyByteString lbs) mlen')+  where+    f :: SomeException -> IO (Either ErrorResponse Content)+    f = return . Left . InternalError . T.pack . show+evaluateContent c = return (Right c)++getStatus :: ErrorResponse -> H.Status+getStatus NotFound = H.status404+getStatus (InternalError _) = H.status500+getStatus (InvalidArgs _) = H.status400+getStatus NotAuthenticated = H.status401+getStatus (PermissionDenied _) = H.status403+getStatus (BadMethod _) = H.status405
+ src/Yesod/Core/Internal/Run.hs view
@@ -0,0 +1,377 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Yesod.Core.Internal.Run+  ( toErrorHandler+  , errFromShow+  , basicRunHandler+  , handleError+  , handleContents+  , evalFallback+  , runHandler+  , safeEh+  , runFakeHandler+  , yesodRunner+  , yesodRender+  , resolveApproot+  )+  where++import           Yesod.Core.Internal.Response+import           Data.ByteString.Builder      (toLazyByteString)+import qualified Data.ByteString.Lazy         as BL+import           Control.Monad.IO.Class       (MonadIO, liftIO)+import           Control.Monad.Logger         (LogLevel (LevelError), LogSource,+                                               liftLoc)+import           Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, InternalState)+import qualified Data.ByteString              as S+import qualified Data.ByteString.Char8        as S8+import qualified Data.IORef                   as I+import qualified Data.Map                     as Map+import           Data.Maybe                   (isJust, fromMaybe)+import           Data.Monoid                  (appEndo)+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           Data.Text.Encoding           (encodeUtf8, decodeUtf8With)+import           Data.Text.Encoding.Error     (lenientDecode)+import           Language.Haskell.TH.Syntax   (Loc, qLocation)+import qualified Network.HTTP.Types           as H+import           Network.Wai+import           System.Log.FastLogger        (LogStr, toLogStr)+import           Yesod.Core.Content+import           Yesod.Core.Class.Yesod+import           Yesod.Core.Types+import           Yesod.Core.Internal.Request  (parseWaiRequest,+                                               tooLargeResponse)+import           Yesod.Core.Internal.Util     (getCurrentMaxExpiresRFC1123)+import           Yesod.Routes.Class           (RenderRoute (..))+import           Control.DeepSeq              (($!!), NFData)+import           UnliftIO.Exception++-- | Convert a synchronous exception into an ErrorResponse+toErrorHandler :: SomeException -> IO ErrorResponse+toErrorHandler e0 = handleAny errFromShow $+    case fromException e0 of+        Just (HCError x) -> evaluate $!! x+        _ -> errFromShow e0++-- | Generate an @ErrorResponse@ based on the shown version of the exception+errFromShow :: SomeException -> IO ErrorResponse+errFromShow x = do+  text <- evaluate (T.pack $ show x) `catchAny` \_ ->+          return (T.pack "Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception")+  return $ InternalError text++-- | Do a basic run of a handler, getting some contents and the final+-- @GHState@. The @GHState@ unfortunately may contain some impure+-- exceptions, but all other synchronous exceptions will be caught and+-- represented by the @HandlerContents@.+basicRunHandler :: ToTypedContent c+                => RunHandlerEnv site site+                -> HandlerFor site c+                -> YesodRequest+                -> InternalState+                -> IO (GHState, HandlerContents)+basicRunHandler rhe handler yreq resState = do+    -- Create a mutable ref to hold the state. We use mutable refs so+    -- that the updates will survive runtime exceptions.+    istate <- I.newIORef defState++    -- Run the handler itself, capturing any runtime exceptions and+    -- converting them into a @HandlerContents@+    contents' <- rheCatchHandlerExceptions rhe+        (do+            res <- unHandlerFor handler (hd istate)+            tc <- evaluate (toTypedContent res)+            -- Success! Wrap it up in an @HCContent@+            return (HCContent defaultStatus tc))+        (\e ->+            case fromException e of+                Just e' -> return e'+                Nothing -> HCError <$> toErrorHandler e)++    -- Get the raw state and return+    state <- I.readIORef istate+    return (state, contents')+  where+    defState = GHState+        { ghsSession = reqSession yreq+        , ghsRBC = Nothing+        , ghsIdent = 1+        , ghsCache = mempty+        , ghsCacheBy = mempty+        , ghsHeaders = mempty+        }+    hd istate = HandlerData+        { handlerRequest = yreq+        , handlerEnv     = rhe+        , handlerState   = istate+        , handlerResource = resState+        }++-- | Convert an @ErrorResponse@ into a @YesodResponse@+handleError :: RunHandlerEnv sub site+            -> YesodRequest+            -> InternalState+            -> Map.Map Text S8.ByteString+            -> [Header]+            -> ErrorResponse+            -> IO YesodResponse+handleError rhe yreq resState finalSession headers e0 = do+    -- Find any evil hidden impure exceptions+    e <- (evaluate $!! e0) `catchAny` errFromShow++    -- Generate a response, leveraging the updated session and+    -- response headers+    flip runInternalState resState $ do+        yar <- rheOnError rhe e yreq+            { reqSession = finalSession+            }+        case yar of+            YRPlain status' hs ct c sess ->+                let hs' = headers ++ hs+                    status+                        | status' == defaultStatus = getStatus e+                        | otherwise = status'+                in return $ YRPlain status hs' ct c sess+            YRWai _ -> return yar+            YRWaiApp _ -> return yar++-- | Convert a @HandlerContents@ into a @YesodResponse@+handleContents :: (ErrorResponse -> IO YesodResponse)+               -> Map.Map Text S8.ByteString+               -> [Header]+               -> HandlerContents+               -> IO YesodResponse+handleContents handleError' finalSession headers contents =+    case contents of+        HCContent status (TypedContent ct c) -> do+            -- Check for impure exceptions hiding in the contents+            ec' <- evaluateContent c+            case ec' of+                Left e -> handleError' e+                Right c' -> return $ YRPlain status headers ct c' finalSession+        HCError e -> handleError' e+        HCRedirect status loc -> do+            let disable_caching x =+                      Header "Cache-Control" "no-cache, must-revalidate"+                    : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"+                    : x+                hs = (if status /= H.movedPermanently301 then disable_caching else id)+                      $ Header "Location" (encodeUtf8 loc) : headers+            return $ YRPlain+                status hs typePlain emptyContent+                finalSession+        HCSendFile ct fp p -> return $ YRPlain+            H.status200+            headers+            ct+            (ContentFile fp p)+            finalSession+        HCCreated loc -> return $ YRPlain+            H.status201+            (Header "Location" (encodeUtf8 loc) : headers)+            typePlain+            emptyContent+            finalSession+        HCWai r -> return $ YRWai r+        HCWaiApp a -> return $ YRWaiApp a++-- | Evaluate the given value. If an exception is thrown, use it to+-- replace the provided contents and then return @mempty@ in place of the+-- evaluated value.+--+-- Note that this also catches async exceptions.+evalFallback :: (Monoid w, NFData w)+             => (forall a. IO a -> (SomeException -> IO a) -> IO a)+             -> HandlerContents+             -> w+             -> IO (w, HandlerContents)+evalFallback catcher contents val = catcher+    (fmap (, contents) (evaluate $!! val))+    (fmap ((mempty, ) . HCError) . toErrorHandler)++-- | Function used internally by Yesod in the process of converting a+-- 'HandlerFor' into an 'Application'. Should not be needed by users.+runHandler :: ToTypedContent c+           => RunHandlerEnv site site+           -> HandlerFor site c+           -> YesodApp+runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do+    -- Get the raw state and original contents+    (state, contents0) <- basicRunHandler rhe handler yreq resState++    -- Evaluate the unfortunately-lazy session and headers,+    -- propagating exceptions into the contents+    (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)+    (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])+    contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)++    -- Convert the HandlerContents into the final YesodResponse+    handleContents+        (handleError rhe yreq resState finalSession headers)+        finalSession+        headers+        contents3++safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())+       -> ErrorResponse+       -> YesodApp+safeEh log' er req = do+    liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError+           $ toLogStr $ "Error handler errored out: " ++ show er+    return $ YRPlain+        H.status500+        []+        typePlain+        (toContent ("Internal Server Error" :: S.ByteString))+        (reqSession req)++-- | Run a 'HandlerFor' completely outside of Yesod.  This+-- function comes with many caveats and you shouldn't use it+-- unless you fully understand what it's doing and how it works.+--+-- As of now, there's only one reason to use this function at+-- all: in order to run unit tests of functions inside 'HandlerFor'+-- but that aren't easily testable with a full HTTP request.+-- Even so, it's better to use @wai-test@ or @yesod-test@ instead+-- of using this function.+--+-- This function will create a fake HTTP request (both @wai@'s+-- 'Request' and @yesod@'s 'Request') and feed it to the+-- @HandlerFor@.  The only useful information the @HandlerFor@ may+-- get from the request is the session map, which you must supply+-- as argument to @runFakeHandler@.  All other fields contain+-- fake information, which means that they can be accessed but+-- won't have any useful information.  The response of the+-- @HandlerFor@ is completely ignored, including changes to the+-- session, cookies or headers.  We only return you the+-- @HandlerFor@'s return value.+runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>+                  SessionMap+               -> (site -> Logger)+               -> site+               -> HandlerFor site a+               -> m (Either ErrorResponse a)+runFakeHandler fakeSessionMap logger site handler = liftIO $ do+  ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")+  maxExpires <- getCurrentMaxExpiresRFC1123+  let handler' = liftIO . I.writeIORef ret . Right =<< handler+  let yapp = runHandler+         RunHandlerEnv+            { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest+            , rheRoute = Nothing+            , rheRouteToMaster = id+            , rheChild = site+            , rheSite = site+            , rheUpload = fileUpload site+            , rheLog = messageLoggerSource site $ logger site+            , rheOnError = errHandler+            , rheMaxExpires = maxExpires+            , rheCatchHandlerExceptions = catchHandlerExceptions site+            }+        handler'+      errHandler err req = do+          liftIO $ I.writeIORef ret (Left err)+          return $ YRPlain+                     H.status500+                     []+                     typePlain+                     (toContent ("runFakeHandler: errHandler" :: S8.ByteString))+                     (reqSession req)+      fakeWaiRequest = defaultRequest+          { requestMethod  = "POST"+          , httpVersion    = H.http11+          , rawPathInfo    = "/runFakeHandler/pathInfo"+          , remoteHost     = error "runFakeHandler-remoteHost"+          , pathInfo       = ["runFakeHandler", "pathInfo"]+          }+      fakeRequest =+        YesodRequest+          { reqGetParams  = []+          , reqCookies    = []+          , reqWaiRequest = fakeWaiRequest+          , reqLangs      = []+          , reqToken      = Just "NaN" -- not a nonce =)+          , reqAccept     = []+          , reqSession    = fakeSessionMap+          }+  _ <- runResourceT $ yapp fakeRequest+  I.readIORef ret++yesodRunner :: forall res site . (ToTypedContent res, Yesod site)+            => HandlerFor site res+            -> YesodRunnerEnv site+            -> Maybe (Route site)+            -> Application+yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do+  mmaxLen <- maximumContentLengthIO yreSite route+  case (mmaxLen, requestBodyLength req) of+    (Just maxLen, KnownLength len) | maxLen < len -> sendResponse (tooLargeResponse maxLen len)+    _ -> do+      let dontSaveSession _ = return []+      (session, saveSession) <- liftIO $+          maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend+      maxExpires <- yreGetMaxExpires+      let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen+      let yreq =+              case mkYesodReq of+                  Left yreq' -> yreq'+                  Right needGen -> needGen yreGen+      let ra = resolveApproot yreSite req+      let log' = messageLoggerSource yreSite yreLogger+          -- We set up two environments: the first one has a "safe" error handler+          -- which will never throw an exception. The second one uses the+          -- user-provided errorHandler function. If that errorHandler function+          -- errors out, it will use the safeEh below to recover.+          rheSafe = RunHandlerEnv+              { rheRender = yesodRender yreSite ra+              , rheRoute = route+              , rheRouteToMaster = id+              , rheChild = yreSite+              , rheSite = yreSite+              , rheUpload = fileUpload yreSite+              , rheLog = log'+              , rheOnError = safeEh log'+              , rheMaxExpires = maxExpires+              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite+              }+          rhe = rheSafe+              { rheOnError = runHandler rheSafe . errorHandler+              }++      yesodWithInternalState yreSite route $ \is -> do+          yreq' <- yreq+          yar <- runInternalState (runHandler rhe handler yreq') is+          yarToResponse yar saveSession yreq' req is sendResponse+  where+    handler = yesodMiddleware handler'++yesodRender :: Yesod y+            => y+            -> ResolvedApproot+            -> Route y+            -> [(Text, Text)] -- ^ url query string+            -> Text+yesodRender y ar url params =+    decodeUtf8With lenientDecode $ BL.toStrict $ toLazyByteString $+    fromMaybe+        (joinPath y ar ps+          $ params ++ params')+        (urlParamRenderOverride y url params)+  where+    (ps, params') = renderRoute url++resolveApproot :: Yesod master => master -> Request -> ResolvedApproot+resolveApproot master req =+    case approot of+        ApprootRelative -> ""+        ApprootStatic t -> t+        ApprootMaster f -> f master+        ApprootRequest f -> f master req
+ src/Yesod/Core/Internal/Session.hs view
@@ -0,0 +1,70 @@+module Yesod.Core.Internal.Session+    ( encodeClientSession+    , decodeClientSession+    , clientSessionDateCacher+    , ClientSessionDateCache(..)+    , SaveSession+    , SessionBackend(..)+    ) where++import qualified Web.ClientSession as CS+import Data.Serialize+import Data.Time+import Data.ByteString (ByteString)+import Control.Monad (guard)+import Yesod.Core.Types+import Yesod.Core.Internal.Util+import Control.AutoUpdate++encodeClientSession :: CS.Key+                    -> CS.IV+                    -> ClientSessionDateCache  -- ^ expire time+                    -> ByteString -- ^ remote host+                    -> SessionMap -- ^ session+                    -> ByteString -- ^ cookie value+encodeClientSession key iv date rhost session' =+    CS.encrypt key iv $ encode $ SessionCookie expires rhost session'+      where expires = Right (csdcExpiresSerialized date)++decodeClientSession :: CS.Key+                    -> ClientSessionDateCache  -- ^ current time+                    -> ByteString -- ^ remote host field+                    -> ByteString -- ^ cookie value+                    -> Maybe SessionMap+decodeClientSession key date rhost encrypted = do+    decrypted <- CS.decrypt key encrypted+    SessionCookie (Left expire) rhost' session' <-+        either (const Nothing) Just $ decode decrypted+    guard $ expire > csdcNow date+    guard $ rhost' == rhost+    return session'+++----------------------------------------------------------------------+++-- Originally copied from Kazu's date-cache, but now using mkAutoUpdate.+--+-- The cached date is updated every 10s, we don't need second+-- resolution for session expiration times.+--+-- The second component of the returned tuple used to be an action that+-- killed the updater thread, but is now a no-op that's just there+-- to preserve the type.++clientSessionDateCacher ::+     NominalDiffTime -- ^ Inactive session validity.+  -> IO (IO ClientSessionDateCache, IO ())+clientSessionDateCacher validity = do+    getClientSessionDateCache <- mkAutoUpdate defaultUpdateSettings+      { updateAction = getUpdated+      , updateFreq   = 10000000 -- 10s+      }++    return (getClientSessionDateCache, return ())+  where+    getUpdated = do+      now <- getCurrentTime+      let expires  = validity `addUTCTime` now+          expiresS = runPut (putTime expires)+      return $! ClientSessionDateCache now expires expiresS
+ src/Yesod/Core/Internal/TH.hs view
@@ -0,0 +1,490 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Yesod.Core.Internal.TH+    ( mkYesod+    , mkYesodOpts++    , mkYesodWith++    , mkYesodData+    , mkYesodDataOpts++    , mkYesodSubData+    , mkYesodSubDataOpts++    , mkYesodWithParser+    , mkYesodWithParserOpts++    , mkYesodDispatch+    , mkYesodDispatchOpts++    , masterTypeSyns++    , mkYesodGeneral+    , mkYesodGeneralOpts++    , mkMDS+    , mkDispatchInstance++    , mkYesodSubDispatch+    , mkYesodSubDispatchInstance+    , mkYesodSubDispatchInstanceOpts+    , mkNestedSubDispatchInstance++    , subTopDispatch++    , RouteOpts+    , defaultOpts+    , setEqDerived+    , setShowDerived+    , setReadDerived+    , setCreateResources+    , setFocusOnNestedRoute+    , unsetFocusOnNestedRoute+    , setParameterizedSubroute+    , setNestedRouteFallthrough+    )+ where++import Prelude hiding (exp)+import Yesod.Core.Handler+import Language.Haskell.TH hiding (cxt, instanceD)+import Language.Haskell.TH.Syntax+import Data.ByteString.Lazy.Char8 ()+import Data.List (foldl')+import Data.Maybe+import Control.Monad+import Yesod.Routes.TH+import Yesod.Routes.TH.Dispatch+    (parseYesodName, mkYesodSubDispatchWithDelegate, SameSpliceNestedInstances (..))+import Yesod.Routes.TH.Internal (instanceD, typeArity, assertNestedSubArity, ArityCallSite(..), SubsiteName(..), SubsiteArity(..), resolveRouteCon, nestedInstanceExists)+import Yesod.Routes.Parse+import Yesod.Core.Types+import Yesod.Core.Class.Dispatch (YesodSubDispatch(..), YesodSubDispatchNested(..))++-- | Generates URL datatype and site function for the given 'Resource's. This+-- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter.+-- Use 'parseRoutes' to create the 'Resource's.+--+-- Contexts and type variables in the name of the datatype are parsed.+-- For example, a datatype @App a@ with typeclass constraint @MyClass a@ can be written as @\"(MyClass a) => App a\"@.+mkYesod :: String -- ^ name of the argument datatype+        -> [ResourceTree String]+        -> Q [Dec]+mkYesod = mkYesodOpts defaultOpts++-- | `mkYesod` but with custom options.+--+-- @since 1.6.25.0+mkYesodOpts :: RouteOpts+            -> String+            -> [ResourceTree String]+            -> Q [Dec]+mkYesodOpts opts name = fmap (uncurry (++)) . mkYesodWithParserOpts opts name False return+++{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}+-- | Similar to 'mkYesod', except contexts and type variables are not parsed.+-- Instead, they are explicitly provided.+-- You can write @(MyClass a) => App a@ with @mkYesodWith [[\"MyClass\",\"a\"]] \"App\" [\"a\"] ...@.+mkYesodWith :: [[String]] -- ^ list of contexts+            -> String -- ^ name of the argument datatype+            -> [String] -- ^ list of type variables+            -> [ResourceTree String]+            -> Q [Dec]+mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return+++-- | Sometimes, you will want to declare your routes in one file and define+-- your handlers elsewhere. For example, this is the only way to break up a+-- monolithic file into smaller parts. Use this function, paired with+-- 'mkYesodDispatch', to do just that.+mkYesodData :: String -> [ResourceTree String] -> Q [Dec]+mkYesodData = mkYesodDataOpts defaultOpts++-- | `mkYesodData` but with custom options.+--+-- @since 1.6.25.0+mkYesodDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]+mkYesodDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name False return resS+++mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]+mkYesodSubData = mkYesodSubDataOpts defaultOpts++-- |+--+-- @since 1.6.25.0+mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]+mkYesodSubDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name True return resS+++-- | Run 'parseYesodName' in 'Q', failing the splice with the parse error+-- instead of returning an 'Either'. Shared by the @mkYesod@ and+-- @mkYesodSubDispatch@ entry points.+parseYesodNameQ :: String -> Q (String, [String], [[String]])+parseYesodNameQ name =+    case parseYesodName name of+        Left err -> fail err+        Right a  -> pure a++-- | Parses contexts and type arguments out of name before generating TH.+mkYesodWithParser :: String                    -- ^ foundation type+                  -> Bool                      -- ^ is this a subsite+                  -> (Exp -> Q Exp)            -- ^ unwrap handler+                  -> [ResourceTree String]+                  -> Q([Dec],[Dec])+mkYesodWithParser = mkYesodWithParserOpts defaultOpts++-- | Parses contexts and type arguments out of name before generating TH.+--+-- @since 1.6.25.0+mkYesodWithParserOpts :: RouteOpts                 -- ^ Additional route options+                      -> String                    -- ^ foundation type+                      -> Bool                      -- ^ is this a subsite+                      -> (Exp -> Q Exp)            -- ^ unwrap handler+                      -> [ResourceTree String]+                      -> Q([Dec],[Dec])+mkYesodWithParserOpts opts name isSub f resS = do+    (name', rest, cxt) <- parseYesodNameQ name++    mkYesodGeneralOpts opts cxt name' rest isSub f resS+++-- | See 'mkYesodData'.+mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]+mkYesodDispatch = mkYesodDispatchOpts defaultOpts++-- | See 'mkYesodDataOpts'+--+-- @since 1.6.25.0+mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]+mkYesodDispatchOpts opts name = fmap snd . mkYesodWithParserOpts opts name False return+++-- | Build an instance context ('Cxt') from the parsed @=>@ class-application+-- groups produced by 'parseYesodName'. Each group is a class name applied to+-- type arguments, e.g. @["MyClass","a"]@ becomes @MyClass a@. Shared by+-- 'mkYesodGeneralOpts' and 'mkYesodSubDispatchInstanceOpts'.+buildAppCxt :: [[String]] -> Q Cxt+buildAppCxt = traverse $ \ctxs ->+    case ctxs of+        c:rest ->+            pure $ foldl' (\acc v -> acc `AppT` fst (nameToType v)) (ConT $ mkName c) rest+        [] -> fail $ "mkYesod: empty type-class context in route definition: " ++ show ctxs++-- | Get the Handler and Widget type synonyms for the given site.+masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself?+masterTypeSyns vs site =+    [ TySynD (mkName "Handler") (fmap plainTV vs)+      $ ConT ''HandlerFor `AppT` site+    , TySynD (mkName "Widget")  (fmap plainTV vs)+      $ ConT ''WidgetFor `AppT` site `AppT` ConT ''()+    ]+++mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.+               -> String                    -- ^ foundation type+               -> [String]                  -- ^ arguments for the type+               -> Bool                      -- ^ is this a subsite+               -> (Exp -> Q Exp)            -- ^ unwrap handler+               -> [ResourceTree String]+               -> Q([Dec],[Dec])+mkYesodGeneral = mkYesodGeneralOpts defaultOpts++-- | Convert the parsed-from-source 'String' route types into real 'Type's at a+-- splice site. A malformed type or an unclosed @#{…}@ bracket surfaces as an+-- attributed compile error (via 'fail') rather than a raw 'error' thrown lazily+-- when the resulting tree is forced. This is the single 'String'-to-'Type'+-- boundary: callers downstream only ever handle @['ResourceTree' 'Type']@.+parseResourceTypes :: [ResourceTree String] -> Q [ResourceTree Type]+parseResourceTypes = traverse (traverse (\s -> dropBracketM s >>= parseTypeM))++-- | Generate a @YesodSubDispatchNested@ instance for a nested route within a+-- subsite, for hand-written split-route modules (see the subsite-splitting+-- recipe in @docs/split-route-compilation.md@).+--+-- Takes the resources as @['ResourceTree' 'String']@ — exactly the form the+-- @parseRoutes@ quasi-quoter produces — and parses them to 'Type' internally+-- via 'parseResourceTypes', so the caller never touches the partial+-- 'parseType'\/'dropBracket'. A malformed type fails the splice with an+-- attributed error instead.+--+-- @since 1.7.0.0+mkNestedSubDispatchInstance+    :: RouteOpts+    -> String                -- ^ target nested route name+    -> Cxt                   -- ^ instance context+    -> TyArgs                -- ^ type arguments+    -> (Exp -> Q Exp)        -- ^ unwrapper+    -> [ResourceTree String] -- ^ all resources (as parsed from source)+    -> Q [Dec]+mkNestedSubDispatchInstance routeOpts target cxt tyargs unwrapper resS = do+    res <- parseResourceTypes resS+    -- Guard the top target's arity here. 'mkNestedDispatchInstanceWith' only+    -- arity-checks nested *children*, so without this a hand-written recipe+    -- pairing a parameterized subsite with an unparameterized target datatype+    -- would apply the subsite's type args to a kind-'Type' head and surface a+    -- cryptic kind error from generated code rather than this actionable one.+    -- A no-op when the datatype is not in scope (unknowable arity) or when the+    -- arities match.+    rc <- resolveRouteCon target+    assertNestedSubArity SubsiteCall (SubsiteName target)+        (SubsiteArity (tyArgsArity tyargs)) rc+    mkNestedDispatchInstanceWith SubsiteNested Nothing+        routeOpts target cxt tyargs unwrapper res++-- | The resolved foundation type shared by 'mkYesodGeneralOpts' and+-- 'mkYesodSubDispatchInstanceOpts': the @boundNames@ from the explicitly-written+-- type args plus enough fresh @t@ variables to fill the reified arity, the fully+-- applied @site@ type, and the parsed resources. The callers differ only in how+-- they roll these into 'TyArgs' (and the synonym-head vars), so that part stays+-- with each caller.+data ResolvedFoundation = ResolvedFoundation+    { rfBoundNames :: [(Type, Name)]  -- ^ explicitly-written type args+    , rfFillVars   :: [Name]          -- ^ fresh vars filling the reified arity+    , rfSite       :: Type            -- ^ the fully applied site type+    , rfResources  :: [ResourceTree Type]+    }++resolveFoundation :: String -> [String] -> [ResourceTree String] -> Q ResolvedFoundation+resolveFoundation namestr mtys resS = do+    mname <- lookupTypeName namestr+    arity <- maybe (pure 0) typeArity mname+    let name = mkName namestr+    -- Generate as many variable names as the arity indicates+    vns <- replicateM (arity - length mtys) $ newName "t"+    let boundNames = fmap nameToType mtys+        argtypes = fmap fst boundNames ++ fmap VarT vns+        site = foldl' AppT (ConT name) argtypes+    res <- parseResourceTypes resS+    pure ResolvedFoundation+        { rfBoundNames = boundNames+        , rfFillVars = vns+        , rfSite = site+        , rfResources = res+        }++-- |+--+-- @since 1.6.25.0+mkYesodGeneralOpts :: RouteOpts                 -- ^ Options to adjust route creation+                   -> [[String]]                -- ^ Application context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.+                   -> String                    -- ^ foundation type+                   -> [String]                  -- ^ arguments for the type+                   -> Bool                      -- ^ is this a subsite+                   -> (Exp -> Q Exp)            -- ^ unwrap handler+                   -> [ResourceTree String]+                   -> Q([Dec],[Dec])+mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do+    appCxt <- buildAppCxt appCxt'+    foundation <- resolveFoundation namestr mtys resS+    -- The explicitly-written args plus the fresh vars filling the reified+    -- arity. Both are part of the site's full application ('rfSite'), so both+    -- must travel in the 'TyArgs' handed to 'discoveryMode' and the generators+    -- — otherwise a parameterized foundation invoked without explicit type args+    -- would be misclassified as monomorphic and emit ill-scoped nested+    -- instances.+    let fillNames = fmap (\v -> (VarT v, v)) (rfFillVars foundation)+        tyArgs = toTyArgs (rfBoundNames foundation ++ fillNames)+    -- typevars that should appear in synonym head+    let argvars = (fmap mkName . filter isTvar) mtys ++ rfFillVars foundation+    renderRouteDec <-+        mkRenderRouteInstanceOpts opts appCxt tyArgs (rfSite foundation) (rfResources foundation)+    routeAttrsDec  <-+        case roFocusOnNestedRoute opts of+            Nothing -> do+                -- The flat 'RouteAttrs (Route site)' instance, plus — in+                -- nested-discovery mode — a 'RouteAttrsNested' instance for each+                -- child fragment, mirroring the RenderRouteNested /+                -- ParseRouteNested / YesodDispatchNested instances generated for+                -- the same children. Without this, 'routeAttrsNested ChildR'+                -- would fail to resolve for a single-module 'mkYesod' site even+                -- though the other nested-delegation methods resolve.+                flatAttrs <- mkRouteAttrsInstance appCxt (rfSite foundation) (rfResources foundation)+                nestedAttrs <-+                    case discoveryMode opts tyArgs of+                        NestedDiscovery ->+                            mkRouteAttrsNestedInstances appCxt tyArgs (rfResources foundation)+                        InlineCompat    -> pure []+                pure (flatAttrs : nestedAttrs)+            Just target ->+                -- Apply the site's type arguments to the focused child's+                -- constructor, matching the focused ParseRoute / RenderRoute+                -- paths; a bare 'ConT' here is a kind error for a+                -- parameterized site.+                mkRouteAttrsInstanceFor+                    appCxt+                    (applyTyArgs (ConT (mkName target)) tyArgs)+                    target+                    (rfResources foundation)++    dispatchDec <-+        mkDispatchInstance opts (rfSite foundation) appCxt tyArgs f (rfResources foundation)+    parseRouteDec <-+        mkParseRouteInstanceOpts opts tyArgs appCxt (rfSite foundation) (rfResources foundation)+    let rname = mkName $ "resources" ++ namestr+    resourcesDec <-+        if shouldCreateResources opts+            then do+                eres <- lift resS+                pure+                    [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)+                    , FunD rname [Clause [] (NormalB eres) []]+                    ]+            else do+                pure []+    let dataDec = concat+            [ parseRouteDec+            , renderRouteDec+            , routeAttrsDec+            , if isJust (roFocusOnNestedRoute opts) then [] else resourcesDec+            , if isSub || isJust (roFocusOnNestedRoute opts)+                then []+                else masterTypeSyns argvars (rfSite foundation)+            ]+    return (dataDec, dispatchDec)++-- | Generate both 'YesodSubDispatch' and 'YesodSubDispatchNested' instances+-- for a parameterized subsite. This is the subsite equivalent of using+-- @mkYesod@ for top-level sites.+--+-- Usage:+--+-- @+-- mkYesodSubDispatchInstance "(MyClass a) => MySub a" resourcesMySub+-- @+--+-- This generates:+--+-- 1. A 'YesodSubDispatch' instance using 'mkYesodSubDispatch'+-- 2. 'YesodSubDispatchNested' instances for any nested route fragments+--+-- The generated instances quantify over the @master@ site and constrain it+-- only through the subsite's own class. For a parameterized subsite this+-- normally means the subsite's class carries a @subsite -> master@ functional+-- dependency (so @master@ is determined) and the using module enables+-- @UndecidableInstances@ (the instance contexts mention type-family+-- applications and non-variable arguments), along with @FlexibleContexts@,+-- @FlexibleInstances@, @MultiParamTypeClasses@ and @TypeFamilies@. The nested+-- route datatype must also declare exactly as many type parameters as the+-- subsite has type arguments (see the arity note below).+--+-- @since 1.7.0.0+mkYesodSubDispatchInstance+    :: String                -- ^ Foundation type with optional context, e.g. @"(MyClass a) => MySub a"@+    -> [ResourceTree String] -- ^ Resources (e.g. @resourcesMySub@)+    -> Q [Dec]+mkYesodSubDispatchInstance = mkYesodSubDispatchInstanceOpts defaultOpts++-- | Like 'mkYesodSubDispatchInstance', but takes a 'RouteOpts' so a subsite can+-- control nested-route generation — most usefully 'setNestedRouteFallthrough'+-- (which 'mkYesodSubDispatchInstance' leaves at its default of 'False'). The+-- flag is threaded into both the @yesodSubDispatch@ body (so the subsite's own+-- top-level parent clauses fall through to later siblings on an inner miss) and+-- the generated @YesodSubDispatchNested@ fragment instances.+--+-- @since 1.7.0.0+mkYesodSubDispatchInstanceOpts+    :: RouteOpts+    -> String                -- ^ Foundation type with optional context, e.g. @"(MyClass a) => MySub a"@+    -> [ResourceTree String] -- ^ Resources (e.g. @resourcesMySub@)+    -> Q [Dec]+mkYesodSubDispatchInstanceOpts opts nameStr resS = do+    -- Parse the name string to extract context, type name, and type args+    -- (the same parser the top-level mkYesod entry points use).+    (namestr, mtys, appCxt') <- parseYesodNameQ nameStr++    appCxt <- buildAppCxt appCxt'++    foundation <- resolveFoundation namestr mtys resS+    -- The explicitly-written args plus the fresh vars filling the reified+    -- arity. Both are part of the subsite's full application ('rfSite'), so both+    -- must travel in the 'TyArgs' handed to 'discoveryMode' and the generators+    -- — otherwise a parameterized subsite invoked without explicit type args+    -- (e.g. @mkYesodSubDispatchInstance "MySub"@ for @MySub a@) would be+    -- misclassified as monomorphic and emit ill-scoped nested instances. This+    -- mirrors the 'fillNames' fix in 'mkYesodGeneralOpts'.+    let fillNames = fmap (\v -> (VarT v, v)) (rfFillVars foundation)+        tyArgs = toTyArgs (rfBoundNames foundation ++ fillNames)++    -- Generate the YesodSubDispatch instance+    masterN <- newName "master"+    let masterT = VarT masterN+        -- Thread the opts (in particular 'roNestedRouteFallthrough') into the+        -- generated @yesodSubDispatch@ body so a subsite's own top-level parent+        -- clauses honor 'setNestedRouteFallthrough', matching the top-level+        -- 'mkTopLevelDispatchInstance' path. 'GeneratesNestedInstances': this+        -- entry point emits a 'YesodSubDispatchNested' instance per parent in+        -- this same splice (below), so the flat @yesodSubDispatch@ body+        -- delegates each parent to that instance instead of inlining the+        -- subtree dispatch (which the nested instance would re-emit), avoiding+        -- the doubled codegen. This mirrors 'mkTopLevelDispatchInstance' on the+        -- top-level path. Standalone 'mkYesodSubDispatch'/'mkYesodSubDispatchWith'+        -- stay at 'NoSameSpliceNestedInstances'.+        subDispatchExp =+            mkYesodSubDispatchWithDelegate+                GeneratesNestedInstances+                opts+                (rfResources foundation)+    subDispatchBody <- subDispatchExp+    let yesodSubDispatchInst = instanceD+            appCxt+            (ConT ''YesodSubDispatch `AppT` rfSite foundation `AppT` masterT)+            [ FunD 'yesodSubDispatch+                [ Clause [] (NormalB subDispatchBody) [] ]+            ]++    -- The top-level nested parents, each of which gets a+    -- YesodSubDispatchNested instance generated below.+    let nestedNames = [ n | ResourceParent n _ _ _ _ <- rfResources foundation ]++    nestedInstances <- fmap mconcat $ forM nestedNames $ \nestedName -> do+        -- Resolve the nested datatype once and reuse it for both the+        -- "instance already exists?" probe and the arity check below.+        -- 'nestedInstanceExists' saturates by the datatype's own reified arity,+        -- so it can't throw a kind error on an arity-mismatched in-scope+        -- datatype — which is exactly the misuse the 'checkNestedSubArity'+        -- below diagnoses. That keeps the friendly arity check reachable+        -- instead of being preempted by a cryptic kind error from the probe.+        rc <- resolveRouteCon nestedName+        instanceExists <- nestedInstanceExists ''YesodSubDispatchNested rc+        if instanceExists+            then pure []+            else do+                -- This API targets parameterized subsites whose nested subroute+                -- datatypes carry the parent's type arguments (the subsite's+                -- 'tyArgs' are applied to the nested datatype directly below).+                -- Guard the misuse where the+                -- subsite is parameterized but the nested datatype is not:+                -- otherwise applying the subsite's type args to a kind-'Type'+                -- datatype produces a cryptic kind error from generated code.+                -- Only check when the datatype actually resolved — an+                -- unresolved name has no knowable arity (defaulting it to 0+                -- would wrongly report "0 type parameter(s)"), and downstream+                -- codegen reports the not-in-scope case on its own.+                assertNestedSubArity+                    SubsiteCall+                    (SubsiteName namestr)+                    (SubsiteArity (tyArgsArity tyArgs))+                    rc+                -- Call the worker directly with the foundation's+                -- already-parsed 'Type' resources, rather than re-parsing the+                -- 'String' resources through the public 'mkNestedSubDispatchInstance'.+                -- The generator applies 'tyArgs' to the nested datatype directly+                -- and never consults 'roParameterizedSubroute' (it only reads+                -- 'roNestedRouteFallthrough'), so passing 'opts' through+                -- unchanged is correct — forcing 'setParameterizedSubroute' here+                -- was a no-op.+                mkNestedDispatchInstanceWith SubsiteNested Nothing+                    opts+                    nestedName appCxt tyArgs return (rfResources foundation)++    return $ yesodSubDispatchInst : nestedInstances
+ src/Yesod/Core/Internal/Util.hs view
@@ -0,0 +1,53 @@+module Yesod.Core.Internal.Util+    ( putTime+    , getTime+    , formatW3+    , formatRFC1123+    , formatRFC822+    , getCurrentMaxExpiresRFC1123+    ) where++import           Data.Int       (Int64)+import           Data.Serialize (Get, Put, Serialize (..))+import qualified Data.Text      as T+import           Data.Time      (Day (ModifiedJulianDay, toModifiedJulianDay),+                                 DiffTime, UTCTime (..), formatTime,+                                 getCurrentTime, addUTCTime, defaultTimeLocale)++putTime :: UTCTime -> Put+putTime (UTCTime d t) =+  let d' = fromInteger  $ toModifiedJulianDay d+      t' = fromIntegral $ fromEnum (t / diffTimeScale)+  in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')++getTime :: Get UTCTime+getTime = do+  val <- get+  let (d, t) = val `divMod` posixDayLength_int64+      d' = ModifiedJulianDay $! fromIntegral d+      t' = fromIntegral t+  d' `seq` t' `seq` return (UTCTime d' t')++posixDayLength_int64 :: Int64+posixDayLength_int64 = 86400++diffTimeScale :: DiffTime+diffTimeScale = 1e12++-- | Format a 'UTCTime' in W3 format.+formatW3 :: UTCTime -> T.Text+formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00"++-- | Format as per RFC 1123.+formatRFC1123 :: UTCTime -> T.Text+formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"++-- | Format as per RFC 822.+formatRFC822 :: UTCTime -> T.Text+formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"++{- | Get the time 365 days from now in RFC 1123 format. For use as an expiry+date on a resource that never expires. See RFC 2616 section 14.21 for details.+-}+getCurrentMaxExpiresRFC1123 :: IO T.Text+getCurrentMaxExpiresRFC1123 = fmap (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime
+ src/Yesod/Core/Json.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Yesod.Core.Json+    ( -- * Convert from a JSON value+      defaultLayoutJson+    , jsonToRepJson+    , returnJson+    , returnJsonEncoding+    , provideJson++      -- * Convert to a JSON value+    , parseCheckJsonBody+    , parseInsecureJsonBody+    , requireCheckJsonBody+    , requireInsecureJsonBody+      -- ** Deprecated JSON conversion+    , parseJsonBody+    , parseJsonBody_+    , requireJsonBody++      -- * Produce JSON values+    , J.Value (..)+    , J.ToJSON (..)+    , J.FromJSON (..)+    , array+    , object+    , (.=)+    , (J..:)++      -- * Convenience functions+    , jsonOrRedirect+    , jsonEncodingOrRedirect+    , acceptsJson++      -- * Checking if data is JSON+    , contentTypeHeaderIsJson+    ) where++import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)+import Control.Monad.Trans.Writer (Writer)+import Data.Monoid (Endo)+import Yesod.Core.Content (TypedContent)+import Yesod.Core.Types (reqAccept)+import Yesod.Core.Class.Yesod (defaultLayout, Yesod)+import Yesod.Core.Class.Handler+import Yesod.Core.Widget (WidgetFor)+import Yesod.Routes.Class+import qualified Data.Aeson as J+import qualified Data.Aeson.Parser as JP+import Data.Aeson ((.=), object)+import Data.Conduit.Attoparsec (sinkParser)+import Data.Text (pack)+import qualified Data.Vector as V+import Data.Conduit+import Data.Conduit.Lift+import qualified Data.ByteString.Char8 as B8+import Data.Maybe (listToMaybe)+import Control.Monad (liftM)++-- | Provide both an HTML and JSON representation for a piece of+-- data, using the default layout for the HTML output+-- ('defaultLayout').+--+-- @since 0.3.0+defaultLayoutJson :: (Yesod site, J.ToJSON a)+                  => WidgetFor site ()  -- ^ HTML+                  -> HandlerFor site a  -- ^ JSON+                  -> HandlerFor site TypedContent+defaultLayoutJson w json = selectRep $ do+    provideRep $ defaultLayout w+    provideRep $ fmap J.toEncoding json++-- | Wraps a data type in a 'RepJson'.  The data type must+-- support conversion to JSON via 'J.ToJSON'.+--+-- @since 0.3.0+jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value+jsonToRepJson = return . J.toJSON+{-# DEPRECATED jsonToRepJson "Use returnJson instead" #-}++-- | Convert a value to a JSON representation via aeson\'s 'J.toJSON' function.+--+-- @since 1.2.1+returnJson :: (Monad m, J.ToJSON a) => a -> m J.Value+returnJson = return . J.toJSON++-- | Convert a value to a JSON representation via aeson\'s 'J.toEncoding' function.+--+-- @since 1.4.21+returnJsonEncoding :: (Monad m, J.ToJSON a) => a -> m J.Encoding+returnJsonEncoding = return . J.toEncoding++-- | Provide a JSON representation for usage with 'selectReps', using aeson\'s+-- 'J.toJSON' (aeson >= 0.11: 'J.toEncoding') function to perform the conversion.+--+-- @since 1.2.1+provideJson :: (Monad m, J.ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()+provideJson = provideRep . return . J.toEncoding++-- | Same as 'parseInsecureJsonBody'+--+-- @since 0.3.0+parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)+parseJsonBody = parseInsecureJsonBody+{-# DEPRECATED parseJsonBody "Use parseCheckJsonBody or parseInsecureJsonBody instead" #-}++-- | Same as 'parseCheckJsonBody', but does not check that the mime type+-- indicates JSON content.+--+-- Note: This function is vulnerable to CSRF attacks.+--+-- @since 1.6.11+parseInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)+parseInsecureJsonBody = do+    eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')+    return $ case eValue of+        Left e -> J.Error $ show e+        Right value -> J.fromJSON value++-- | Parse the request body to a data type as a JSON value.  The+-- data type must support conversion from JSON via 'J.FromJSON'.+-- If you want the raw JSON value, just ask for a @'J.Result'+-- 'J.Value'@.+--+-- The MIME type must indicate JSON content. Requiring a JSON+-- content-type helps secure your site against CSRF attacks+-- (browsers will perform POST requests for form and text/plain+-- content-types without doing a CORS check, and those content-types+-- can easily contain valid JSON).+--+-- Note that this function will consume the request body. As such, calling it+-- twice will result in a parse error on the second call, since the request+-- body will no longer be available.+--+-- @since 0.3.0+parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)+parseCheckJsonBody = do+    mct <- lookupHeader "content-type"+    case fmap contentTypeHeaderIsJson mct of+        Just True -> parseInsecureJsonBody+        _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct++-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse+-- error.+parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a+parseJsonBody_ = requireInsecureJsonBody+{-# DEPRECATED parseJsonBody_ "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}++-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse+-- error.+requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a+requireJsonBody = requireInsecureJsonBody+{-# DEPRECATED requireJsonBody "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}++-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse+-- error.+--+-- @since 1.6.11+requireInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m a+requireInsecureJsonBody = do+    ra <- parseInsecureJsonBody+    case ra of+        J.Error s -> invalidArgs [pack s]+        J.Success a -> return a++-- | Same as 'parseCheckJsonBody', but return an invalid args response on a parse+-- error.+requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a+requireCheckJsonBody = do+    ra <- parseCheckJsonBody+    case ra of+        J.Error s -> invalidArgs [pack s]+        J.Success a -> return a++-- | Convert a list of values to an 'J.Array'.+array :: J.ToJSON a => [a] -> J.Value+array = J.Array . V.fromList . map J.toJSON++-- | jsonOrRedirect simplifies the scenario where a POST handler sends a different+-- response based on Accept headers:+--+--     1. 200 with JSON data if the client prefers+--     @application\/json@ (e.g. AJAX, see 'acceptsJSON').+--+--     2. 3xx otherwise, following the PRG pattern.+jsonOrRedirect :: (MonadHandler m, J.ToJSON a)+               => Route (HandlerSite m) -- ^ Redirect target+               -> a            -- ^ Data to send via JSON+               -> m J.Value+jsonOrRedirect = jsonOrRedirect' J.toJSON++-- | jsonEncodingOrRedirect simplifies the scenario where a POST handler sends a different+-- response based on Accept headers:+--+--     1. 200 with JSON data if the client prefers+--     @application\/json@ (e.g. AJAX, see 'acceptsJSON').+--+--     2. 3xx otherwise, following the PRG pattern.+-- @since 1.4.21+jsonEncodingOrRedirect :: (MonadHandler m, J.ToJSON a)+            => Route (HandlerSite m) -- ^ Redirect target+            -> a            -- ^ Data to send via JSON+            -> m J.Encoding+jsonEncodingOrRedirect = jsonOrRedirect' J.toEncoding++jsonOrRedirect' :: MonadHandler m+            => (a -> b)+            -> Route (HandlerSite m) -- ^ Redirect target+            -> a            -- ^ Data to send via JSON+            -> m b+jsonOrRedirect' f r j = do+    q <- acceptsJson+    if q then return (f j)+         else redirect r++-- | Returns @True@ if the client prefers @application\/json@ as+-- indicated by the @Accept@ HTTP header.+acceptsJson :: MonadHandler m => m Bool+acceptsJson =  (maybe False ((== "application/json") . B8.takeWhile (/= ';'))+            .  listToMaybe+            .  reqAccept)+           `liftM` getRequest++-- | Given the @Content-Type@ header, returns if it is JSON.+--+-- This function is currently a simple check for @application/json@, but in the future may check for+-- alternative representations such as @<https://tools.ietf.org/html/rfc6839#section-3.1 xxx/yyy+json>@.+--+-- @since 1.6.17+contentTypeHeaderIsJson :: B8.ByteString -> Bool+contentTypeHeaderIsJson bs = B8.takeWhile (/= ';') bs == "application/json"
+ src/Yesod/Core/TypeCache.hs view
@@ -0,0 +1,96 @@+-- | a module for caching a monadic action based on its return type+--+-- The cache is a HashMap where the key uses the TypeReP from Typeable.+-- The value stored is toDyn from Dynamic to support arbitrary value types in the same Map.+--+-- un-exported newtype wrappers should be used to maintain unique keys in the cache.+-- Note that a TypeRep is unique to a module in a package, so types from different modules will not conflict if they have the same name.+--+-- used in 'Yesod.Core.Handler.cached' and 'Yesod.Core.Handler.cachedBy'+module Yesod.Core.TypeCache (cached, cacheGet, cacheSet, cachedBy, cacheByGet, cacheBySet, TypeMap, KeyedTypeMap) where++import           Prelude hiding (lookup)+import           Data.Typeable                      (Typeable, TypeRep, typeOf)+import           Data.HashMap.Strict+import           Data.ByteString                    (ByteString)+import           Data.Dynamic                       (Dynamic, toDyn, fromDynamic)++type TypeMap      = HashMap TypeRep Dynamic+type KeyedTypeMap = HashMap (TypeRep, ByteString) Dynamic++-- | avoid performing the same action multiple times.+-- Values are stored by their TypeRep from Typeable.+-- Therefore, you should use un-exported newtype wrappers for each cache.+--+-- For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth.+-- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts.+--+-- In Yesod, this is used for a request-local cache that is cleared at the end of every request.+-- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>+--+-- Since 1.4.0+cached :: (Monad m, Typeable a)+       => TypeMap+       -> m a                       -- ^ cache the result of this action+       -> m (Either (TypeMap, a) a) -- ^ Left is a cache miss, Right is a hit+cached cache action = case cacheGet cache of+    Just val -> return $ Right val+    Nothing -> do+        val <- action+        return $ Left (cacheSet val cache, val)++-- | Retrieves a value from the cache+--+-- @since 1.6.10+cacheGet :: Typeable a => TypeMap -> Maybe a+cacheGet cache = res+  where+    res = lookup (typeOf $ fromJust res) cache >>= fromDynamic+    fromJust :: Maybe a -> a+    fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"++-- | Sets a value in the cache+--+-- @since 1.6.10+cacheSet :: (Typeable a)+         => a+         -> TypeMap+         -> TypeMap+cacheSet v cache = insert (typeOf v) (toDyn v) cache++-- | similar to 'cached'.+-- 'cached' can only cache a single value per type.+-- 'cachedBy' stores multiple values per type by indexing on a ByteString key+--+-- 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user+-- 'cachedBy' is required if the action has parameters and can return multiple values per type.+-- You can turn those parameters into a ByteString cache key.+-- For example, caching a lookup of a Link by a token where multiple token lookups might be performed.+--+-- Since 1.4.0+cachedBy :: (Monad m, Typeable a)+         => KeyedTypeMap+         -> ByteString                     -- ^ a cache key+         -> m a                            -- ^ cache the result of this action+         -> m (Either (KeyedTypeMap, a) a) -- ^ Left is a cache miss, Right is a hit+cachedBy cache k action = case cacheByGet k cache of+    Just val -> return $ Right val+    Nothing -> do+        val <- action+        return $ Left (cacheBySet k val cache, val)++-- | Retrieves a value from the keyed cache+--+-- @since 1.6.10+cacheByGet :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a+cacheByGet key c = res+  where+    res = lookup (typeOf $ fromJust res, key) c >>= fromDynamic+    fromJust :: Maybe a -> a+    fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"++-- | Sets a value in the keyed cache+--+-- @since 1.6.10+cacheBySet :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap+cacheBySet key v cache = insert (typeOf v, key) (toDyn v) cache
+ src/Yesod/Core/Types.hs view
@@ -0,0 +1,543 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-}++module Yesod.Core.Types (+    module Yesod.Core.Types+  , module Yesod.Core.Types.ErrorResponse+  , module Yesod.Core.Types.Content+  , module Yesod.Core.Types.TypedContent+  , module Yesod.Core.Types.HandlerContents++  , module Yesod.Core.Internal.Util+  , module Yesod.Routes.Class+  , module Yesod.Core.TypeCache+  ) where++import Data.Aeson (ToJSON)+import qualified Data.ByteString.Builder            as BB+import           Control.Arrow                      (first)+import           Control.Exception                  (Exception)+import           Control.Monad                      (ap)+import           Control.Monad.IO.Class             (MonadIO (liftIO))+import           Control.Monad.Logger               (LogLevel, LogSource,+                                                     MonadLogger (..))+import           Control.Monad.Primitive            (PrimMonad (..))+import           Control.Monad.Trans.Resource       (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)+import           Data.ByteString                    (ByteString)+import qualified Data.ByteString.Lazy               as L+import           Data.CaseInsensitive               (CI)+import           Data.Conduit                       (Flush, ConduitT)+import           Data.IORef                         (IORef, modifyIORef')+import           Data.Map                           (Map, unionWith)+import qualified Data.Map                           as Map+import           Data.Monoid                        (Endo (..), Last (..))+import           Data.Serialize                     (Serialize (..),+                                                     putByteString)+import           Data.String                        (IsString (fromString))+import           Data.Text                          (Text)+import qualified Data.Text                          as T+import           Data.Text.Encoding+import qualified Data.Text.Lazy.Builder             as TBuilder+import           Data.Time                          (UTCTime)+import           GHC.Generics                       (Generic)+import qualified GHC.Int                            as I+import           Language.Haskell.TH.Syntax         (Loc)+import qualified Network.HTTP.Types                 as H+import           Network.Wai                        (FilePart,+                                                     RequestBodyLength)+import qualified Network.Wai                        as W+import qualified Network.Wai.Parse                  as NWP+import           System.Log.FastLogger              (LogStr, LoggerSet, toLogStr, pushLogStr)+import           Network.Wai.Logger                 (DateCacheGetter)+import           Text.Blaze.Html                    (Html, toHtml)+import           Text.Hamlet                        (HtmlUrl)+import           Text.Julius                        (JavascriptUrl)+import           Web.Cookie                         (SetCookie)+import           Yesod.Core.Internal.Util           (getTime, putTime)+import           Yesod.Routes.Class                 (RenderRoute (..), ParseRoute (..))+import           Control.Monad.Reader               (MonadReader (..))+import Control.DeepSeq (NFData (rnf))+import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)+import Control.Monad.Logger (MonadLoggerIO (..))+import UnliftIO (MonadUnliftIO (..), SomeException)++import Yesod.Core.Types.ErrorResponse+import Yesod.Core.Types.Content+import Yesod.Core.Types.TypedContent+import Yesod.Core.Types.HandlerContents++-- Sessions+type SessionMap = Map Text ByteString++type SaveSession = SessionMap -- ^ The session contents after running the handler+                -> IO [Header]++newtype SessionBackend = SessionBackend+    { sbLoadSession :: W.Request+                    -> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session+    }++data SessionCookie = SessionCookie !(Either UTCTime ByteString) !ByteString !SessionMap+    deriving (Show, Read)+instance Serialize SessionCookie where+    put (SessionCookie a b c) = do+        either putTime putByteString a+        put b+        put (map (first T.unpack) $ Map.toList c)++    get = do+        a <- getTime+        b <- get+        c <- map (first T.pack) <$> get+        return $ SessionCookie (Left a) b (Map.fromList c)++data ClientSessionDateCache =+  ClientSessionDateCache {+    csdcNow               :: !UTCTime+  , csdcExpires           :: !UTCTime+  , csdcExpiresSerialized :: !ByteString+  } deriving (Eq, Show)++-- | The parsed request information. This type augments the standard WAI+-- 'W.Request' with additional information.+data YesodRequest = YesodRequest+    { reqGetParams  :: ![(Text, Text)]+      -- ^ Same as 'W.queryString', but decoded to @Text@.+    , reqCookies    :: ![(Text, Text)]+    , reqWaiRequest :: !W.Request+    , reqLangs      :: ![Text]+      -- ^ Languages which the client supports. This is an ordered list by preference.+    , reqToken      :: !(Maybe Text)+      -- ^ A random, session-specific token used to prevent CSRF attacks.+    , reqSession    :: !SessionMap+      -- ^ Initial session sent from the client.+      --+      -- Since 1.2.0+    , reqAccept     :: ![ContentType]+      -- ^ An ordered list of the accepted content types.+      --+      -- Since 1.2.0+    }++-- | An augmented WAI 'W.Response'. This can either be a standard @Response@,+-- or a higher-level data structure which Yesod will turn into a @Response@.+data YesodResponse+    = YRWai !W.Response+    | YRWaiApp !W.Application+    | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap++-- | A tuple containing both the POST parameters and submitted files.+type RequestBodyContents =+    ( [(Text, Text)]+    , [(Text, FileInfo)]+    )++data FileInfo = FileInfo+    { fileName        :: !Text+    , fileContentType :: !Text+    , fileSourceRaw   :: !(ConduitT () ByteString (ResourceT IO) ())+    , fileMove        :: !(FilePath -> IO ())+    }++data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)+                | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)+                | FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ()))++-- | How to determine the root of the application for constructing URLs.+--+-- Note that future versions of Yesod may add new constructors without bumping+-- the major version number. As a result, you should /not/ pattern match on+-- @Approot@ values.+data Approot master = ApprootRelative -- ^ No application root.+                    | ApprootStatic !Text+                    | ApprootMaster !(master -> Text)+                    | ApprootRequest !(master -> W.Request -> Text)++type ResolvedApproot = Text++data AuthResult = Authorized | AuthenticationRequired | Unauthorized !Text+    deriving (Eq, Show, Read)++data ScriptLoadPosition master+    = BottomOfBody+    | BottomOfHeadBlocking+    | BottomOfHeadAsync !(BottomOfHeadAsync master)++type BottomOfHeadAsync master+       = [Text] -- ^ urls to load asynchronously+      -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion+      -> HtmlUrl (Route master) -- ^ widget to insert at the bottom of <head>++type Texts = [Text]++-- | Wrap up a normal WAI application as a Yesod subsite. Ignore parent site's middleware and isAuthorized.+newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }++-- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized.+--+-- @since 1.4.34+newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }++data RunHandlerEnv child site = RunHandlerEnv+    { rheRender   :: !(Route site -> [(Text, Text)] -> Text)+    , rheRoute    :: !(Maybe (Route child))+    , rheRouteToMaster :: !(Route child -> Route site)+    , rheSite     :: !site+    , rheChild    :: !child+    , rheUpload   :: !(RequestBodyLength -> FileUpload)+    , rheLog      :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())+    , rheOnError  :: !(ErrorResponse -> YesodApp)+      -- ^ How to respond when an error is thrown internally.+      --+      -- Since 1.2.0+    , rheMaxExpires :: !Text++      -- | @since 1.6.24.0+      --   catch function for rendering 500 pages on exceptions.+      --   by default this is catch from unliftio (rethrows all async exceptions).+    , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m =>  m a -> (SomeException -> m a) -> m a)+    }++data HandlerData child site = HandlerData+    { handlerRequest  :: !YesodRequest+    , handlerEnv      :: !(RunHandlerEnv child site)+    , handlerState    :: !(IORef GHState)+    , handlerResource :: !InternalState+    }++data YesodRunnerEnv site = YesodRunnerEnv+    { yreLogger         :: !Logger+    , yreSite           :: !site+    , yreSessionBackend :: !(Maybe SessionBackend)+    , yreGen            :: !(IO Int)+    -- ^ Generate a random number uniformly distributed in the full+    -- range of 'Int'.+    --+    -- Note: Before 1.6.20, the default value generates pseudo-random+    -- number in an unspecified range. The range size may not be a power+    -- of 2. Since 1.6.20, the default value uses a secure entropy source+    -- and generates in the full range of 'Int'.+    , yreGetMaxExpires  :: !(IO Text)+    }++data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv+    { ysreParentRunner  :: !(ParentRunner parent)+    , ysreGetSub        :: !(parent -> sub)+    , ysreToParentRoute :: !(Route sub -> Route parent)+    , ysreParentEnv     :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner?+    }++type ParentRunner parent+    = HandlerFor parent TypedContent+   -> YesodRunnerEnv parent+   -> Maybe (Route parent)+   -> W.Application++-- | A generic handler monad, which can have a different subsite and master+-- site. We define a newtype for better error message.+newtype HandlerFor site a = HandlerFor+    { unHandlerFor :: HandlerData site site -> IO a+    }+    deriving Functor++data GHState = GHState+    { ghsSession :: !SessionMap+    , ghsRBC     :: !(Maybe RequestBodyContents)+    , ghsIdent   :: !Int+    , ghsCache   :: !TypeMap+    , ghsCacheBy :: !KeyedTypeMap+    , ghsHeaders :: !(Endo [Header])+    }++-- | An extension of the basic WAI 'W.Application' datatype to provide extra+-- features needed by Yesod. Users should never need to use this directly, as+-- the 'HandlerFor' monad and template haskell code should hide it away.+type YesodApp = YesodRequest -> ResourceT IO YesodResponse++-- | A generic widget, allowing specification of both the subsite and master+-- site datatypes. While this is simply a @WriterT@, we define a newtype for+-- better error messages.+newtype WidgetFor site a = WidgetFor+    { unWidgetFor :: WidgetData site -> IO a+    }+    deriving Functor++data WidgetData site = WidgetData+  { wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))+  , wdHandler :: {-# UNPACK #-} !(HandlerData site site)+  }++instance a ~ () => Monoid (WidgetFor site a) where+    mempty = return ()+instance a ~ () => Semigroup (WidgetFor site a) where+    x <> y = x >> y++-- | A 'String' can be trivially promoted to a widget.+--+-- For example, in a yesod-scaffold site you could use:+--+-- @getHomeR = do defaultLayout "Widget text"@+instance a ~ () => IsString (WidgetFor site a) where+    fromString = toWidget . toHtml . T.pack+      where toWidget x = tellWidget mempty { gwdBody = Body (const x) }++tellWidget :: GWData (Route site) -> WidgetFor site ()+tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d)++type RY master = Route master -> [(Text, Text)] -> Text++-- | Newtype wrapper allowing injection of arbitrary content into CSS.+--+-- Usage:+--+-- > toWidget $ CssBuilder "p { color: red }"+--+-- Since: 1.1.3+newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }++-- | Content for a web page. By providing this datatype, we can easily create+-- generic site templates, which would have the type signature:+--+-- > PageContent url -> HtmlUrl url+data PageContent url = PageContent+    { pageTitle       :: !Html+    , pageDescription :: !(Maybe Text)+    , pageHead        :: !(HtmlUrl url)+    , pageBody        :: !(HtmlUrl url)+    }++type RepHtml = Html+{-# DEPRECATED RepHtml "Please use Html instead" #-}+newtype RepJson = RepJson Content+newtype RepPlain = RepPlain Content+newtype RepXml = RepXml Content++-- | Wrapper around types so that Handlers can return a domain type, even when+-- the data will eventually be encoded as JSON.+-- Example usage in a type signature:+--+-- > postSignupR :: Handler (JSONResponse CreateUserResponse)+--+-- And in the implementation:+--+-- > return $ JSONResponse $ CreateUserResponse userId+--+-- @since 1.6.14+data JSONResponse a where+    JSONResponse :: ToJSON a => a -> JSONResponse a++-- | Prevents a response body from being fully evaluated before sending the+-- request.+--+-- Since 1.1.0+newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }++----- header stuff+-- | Headers to be added to a 'Result'.+data Header =+      AddCookie !SetCookie+    | DeleteCookie !ByteString !ByteString+    -- ^ name and path+    | Header !(CI ByteString) !ByteString+    -- ^ key and value+    deriving (Eq, Show)++-- FIXME In the next major version bump, let's just add strictness annotations+-- to Header (and probably everywhere else). We can also add strictness+-- annotations to SetCookie in the cookie package.+instance NFData Header where+    rnf (AddCookie x) = rnf x+    rnf (DeleteCookie x y) = x `seq` y `seq` ()+    rnf (Header x y) = x `seq` y `seq` ()++data Location url = Local !url | Remote !Text+    deriving (Show, Eq)++-- | A diff list that does not directly enforce uniqueness.+-- When creating a widget Yesod will use nub to make it unique.+newtype UniqueList x = UniqueList ([x] -> [x])++data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :: ![(Text, Text)] }+    deriving (Show, Eq)+data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }+    deriving (Show, Eq)+newtype Title = Title { unTitle :: Html }+newtype Description = Description { unDescription :: Text }++newtype Head url = Head (HtmlUrl url)+    deriving (Semigroup, Monoid)+newtype Body url = Body (HtmlUrl url)+    deriving (Semigroup, Monoid)++type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder++data GWData a = GWData+    { gwdBody        :: !(Body a)+    , gwdTitle       :: !(Last Title)+    , gwdDescription :: !(Last Description)+    , gwdScripts     :: !(UniqueList (Script a))+    , gwdStylesheets :: !(UniqueList (Stylesheet a))+    , gwdCss         :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type+    , gwdJavascript  :: !(Maybe (JavascriptUrl a))+    , gwdHead        :: !(Head a)+    }+instance Monoid (GWData a) where+    mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty+instance Semigroup (GWData a) where+    GWData a1 a2 a3 a4 a5 a6 a7 a8 <>+      GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData+        (mappend a1 b1)+        (mappend a2 b2)+        (mappend a3 b3)+        (mappend a4 b4)+        (mappend a5 b5)+        (unionWith mappend a6 b6)+        (mappend a7 b7)+        (mappend a8 b8)++-- Instances for WidgetFor+instance Applicative (WidgetFor site) where+    pure = WidgetFor . const . pure+    (<*>) = ap+instance Monad (WidgetFor site) where+    return = pure+    WidgetFor x >>= f = WidgetFor $ \wd -> do+        a <- x wd+        unWidgetFor (f a) wd+instance MonadIO (WidgetFor site) where+    liftIO = WidgetFor . const+-- | @since 1.6.7+instance PrimMonad (WidgetFor site) where+    type PrimState (WidgetFor site) = PrimState IO+    primitive = liftIO . primitive+-- | @since 1.4.38+instance MonadUnliftIO (WidgetFor site) where+  {-# INLINE withRunInIO #-}+  withRunInIO inner = WidgetFor $ \x -> inner $ flip unWidgetFor x+instance MonadReader (WidgetData site) (WidgetFor site) where+    ask = WidgetFor return+    local f (WidgetFor g) = WidgetFor $ g . f++instance MonadThrow (WidgetFor site) where+    throwM = liftIO . throwM++instance MonadResource (WidgetFor site) where+    liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler++instance MonadLogger (WidgetFor site) where+    monadLoggerLog a b c d = WidgetFor $ \wd ->+        rheLog (handlerEnv $ wdHandler wd) a b c (toLogStr d)++instance MonadLoggerIO (WidgetFor site) where+    askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler++-- Instances for HandlerFor+instance Applicative (HandlerFor site) where+    pure = HandlerFor . const . return+    (<*>) = ap+instance Monad (HandlerFor site) where+    return = pure+    HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r+instance MonadIO (HandlerFor site) where+    liftIO = HandlerFor . const+-- | @since 1.6.7+instance PrimMonad (HandlerFor site) where+    type PrimState (HandlerFor site) = PrimState IO+    primitive = liftIO . primitive+instance MonadReader (HandlerData site site) (HandlerFor site) where+    ask = HandlerFor return+    local f (HandlerFor g) = HandlerFor $ g . f++-- | @since 1.4.38+instance MonadUnliftIO (HandlerFor site) where+  {-# INLINE withRunInIO #-}+  withRunInIO inner = HandlerFor $ \x -> inner $ flip unHandlerFor x++instance MonadThrow (HandlerFor site) where+    throwM = liftIO . throwM++instance MonadResource (HandlerFor site) where+    liftResourceT f = HandlerFor $ runInternalState f . handlerResource++instance MonadLogger (HandlerFor site) where+    monadLoggerLog a b c d = HandlerFor $ \hd ->+        rheLog (handlerEnv hd) a b c (toLogStr d)++instance MonadLoggerIO (HandlerFor site) where+    askLoggerIO = HandlerFor $ \hd -> return (rheLog (handlerEnv hd))++instance Monoid (UniqueList x) where+    mempty = UniqueList id+instance Semigroup (UniqueList x) where+    UniqueList x <> UniqueList y = UniqueList $ x . y++instance IsString Content where+    fromString = flip ContentBuilder Nothing . BB.stringUtf8++instance RenderRoute WaiSubsite where+    data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]+        deriving (Show, Eq, Read, Ord)+    renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)+instance ParseRoute WaiSubsite where+    parseRoute (x, y) = Just $ WaiSubsiteRoute x y++instance RenderRoute WaiSubsiteWithAuth where+  data Route WaiSubsiteWithAuth = WaiSubsiteWithAuthRoute [Text] [(Text,Text)]+       deriving (Show, Eq, Read, Ord)+  renderRoute (WaiSubsiteWithAuthRoute ps qs) = (ps,qs)++instance ParseRoute WaiSubsiteWithAuth where+  parseRoute (x, y) = Just $ WaiSubsiteWithAuthRoute x y++data Logger = Logger+    { loggerSet :: !LoggerSet+    , loggerDate :: !DateCacheGetter+    }++loggerPutStr :: Logger -> LogStr -> IO ()+loggerPutStr (Logger ls _) = pushLogStr ls++-- | A handler monad for subsite+--+-- @since 1.6.0+newtype SubHandlerFor sub master a = SubHandlerFor+    { unSubHandlerFor :: HandlerData sub master -> IO a+    }+    deriving Functor++instance Applicative (SubHandlerFor child master) where+    pure = SubHandlerFor . const . return+    (<*>) = ap+instance Monad (SubHandlerFor child master) where+    return = pure+    SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r+instance MonadIO (SubHandlerFor child master) where+    liftIO = SubHandlerFor . const+instance MonadReader (HandlerData child master) (SubHandlerFor child master) where+    ask = SubHandlerFor return+    local f (SubHandlerFor g) = SubHandlerFor $ g . f++-- | @since 1.4.38+instance MonadUnliftIO (SubHandlerFor child master) where+  {-# INLINE withRunInIO #-}+  withRunInIO inner = SubHandlerFor $ \x -> inner $ flip unSubHandlerFor x++instance MonadThrow (SubHandlerFor child master) where+    throwM = liftIO . throwM++instance MonadResource (SubHandlerFor child master) where+    liftResourceT f = SubHandlerFor $ runInternalState f . handlerResource++instance MonadLogger (SubHandlerFor child master) where+    monadLoggerLog a b c d = SubHandlerFor $ \sd ->+        rheLog (handlerEnv sd) a b c (toLogStr d)++instance MonadLoggerIO (SubHandlerFor child master) where+    askLoggerIO = SubHandlerFor $ return . rheLog . handlerEnv
+ src/Yesod/Core/Types/Content.hs view
@@ -0,0 +1,21 @@+module Yesod.Core.Types.Content where++import qualified Data.ByteString.Builder as BB+import Control.Monad.Trans.Resource (ResourceT)+import Data.Conduit (Flush, ConduitT)+import Network.Wai (FilePart)++data Content+    = ContentBuilder !BB.Builder !(Maybe Int)+    -- ^ The content and optional content length.+    --+    -- Note that, despite @Builder@'s laziness, this is entirely forced+    -- into memory by default in order to catch imprecise exceptions+    -- before beginning to respond. If you are confident you don't have+    -- imprecise exceptions, you may disable this by wrapping the+    -- `ToContent` data in `DontFullyEvaluate`.+    | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())+    | ContentFile !FilePath !(Maybe FilePart)+    | ContentDontEvaluate !Content+    -- ^ Used internally to wrap @ContentBuilder@s to disable forcing+    -- them. No effect on other @Content@.
+ src/Yesod/Core/Types/ErrorResponse.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DeriveGeneric #-}++module Yesod.Core.Types.ErrorResponse where++import GHC.Generics (Generic)+import Data.Text+import Control.DeepSeq (NFData)+import qualified Network.HTTP.Types as H++-- | Responses to indicate some form of an error occurred.+data ErrorResponse =+      NotFound+        -- ^ The requested resource was not found.+        -- Examples of when this occurs include when an incorrect URL is used, or @yesod-persistent@'s 'get404' doesn't find a value.+        -- HTTP status: 404.+    | InternalError !Text+        -- ^ Some sort of unexpected exception.+        -- If your application uses `throwIO` or `error` to throw an exception, this is the form it would take.+        -- HTTP status: 500.+    | InvalidArgs ![Text]+        -- ^ Indicates some sort of invalid or missing argument, like a missing query parameter or malformed JSON body.+        -- Examples Yesod functions that send this include 'requireCheckJsonBody' and @Yesod.Auth.GoogleEmail2@.+        -- HTTP status: 400.+    | NotAuthenticated+        -- ^ Indicates the user is not logged in.+        -- This is thrown when 'isAuthorized' returns 'AuthenticationRequired'.+        -- HTTP code: 401.+    | PermissionDenied !Text+        -- ^ Indicates the user doesn't have permission to access the requested resource.+        -- This is thrown when 'isAuthorized' returns 'Unauthorized'.+        -- HTTP code: 403.+    | BadMethod !H.Method+        -- ^ Indicates the URL would have been valid if used with a different HTTP method (e.g. a GET was used, but only POST is handled.)+        -- HTTP code: 405.+    deriving (Show, Eq, Generic)++instance NFData ErrorResponse
+ src/Yesod/Core/Types/HandlerContents.hs view
@@ -0,0 +1,39 @@+module Yesod.Core.Types.HandlerContents+  (+    HandlerContents (..)+  ) where++import Control.Exception (Exception)+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Network.HTTP.Types as H+import qualified Network.Wai as W+import Yesod.Core.Types.ErrorResponse+import Yesod.Core.Types.TypedContent (ContentType, TypedContent (..), typedContentToSnippet)++data HandlerContents =+      HCContent !H.Status !TypedContent+    | HCError !ErrorResponse+    | HCSendFile !ContentType !FilePath !(Maybe W.FilePart)+    | HCRedirect !H.Status !T.Text+    | HCCreated !T.Text+    | HCWai !W.Response+    | HCWaiApp !W.Application++instance Show HandlerContents where+    show (HCContent status tc@(TypedContent t _))+      = mconcat [ "HCContent "+                , show (status, t)+                , " ("+                , fromMaybe "" $ TL.unpack <$> typedContentToSnippet tc 1000+                , ")"+                ]+    show (HCError e) = "HCError " ++ show e+    show (HCSendFile ct fp mfp) = "HCSendFile " ++ show (ct, fp, mfp)+    show (HCRedirect s t) = "HCRedirect " ++ show (s, t)+    show (HCCreated t) = "HCCreated " ++ show t+    show (HCWai _) = "HCWai"+    show (HCWaiApp _) = "HCWaiApp"++instance Exception HandlerContents
+ src/Yesod/Core/Types/TypedContent.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Core.Types.TypedContent+  (+    ContentType+  , TypedContent (..)+  , typedContentToSnippet+  ) where++import Control.Applicative ((<|>))+import Control.Monad (void, guard)+import Data.Maybe (fromMaybe)++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Builder as BB++import qualified Data.Int as I++#if MIN_VERSION_text(2,1,0)+import qualified Data.Text.Encoding as TE (decodeASCIIPrefix)+#else+import qualified Data.Text.Encoding as TE (decodeLatin1)+#endif+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as LE (decodeUtf8With, decodeLatin1)+import qualified Data.Text.Encoding.Error as EE (lenientDecode)++import qualified Data.Encoding as Enc+import qualified Data.Encoding.GB18030 as Enc+import qualified Data.Encoding.CP1251 as Enc+import qualified Data.Encoding.ShiftJIS as Enc+import qualified Data.Encoding.CP932 as Enc++import qualified Network.Wai.Parse as NWP++import Yesod.Core.Types.Content (Content (..))++type ContentType = B.ByteString -- FIXME Text?+data TypedContent = TypedContent !ContentType !Content++decoderForCharset :: Maybe B.ByteString -> L.ByteString -> TL.Text+decoderForCharset (Just encodingSymbol)+  | encodingSymbol == "utf-8" =+      LE.decodeUtf8With EE.lenientDecode+  | encodingSymbol == "US-ASCII" =+#if MIN_VERSION_text(2,1,0)+      TL.fromStrict . fst . TE.decodeASCIIPrefix . L.toStrict+#else+      TL.fromStrict . TE.decodeLatin1 . L.toStrict+#endif+  | encodingSymbol == "latin1" =+      LE.decodeLatin1+  | encodingSymbol == "GB18030" =+      TL.pack . Enc.decodeLazyByteString Enc.GB18030+  | encodingSymbol == "windows-1251" =+      TL.pack . Enc.decodeLazyByteString Enc.CP1251+  | encodingSymbol == "Shift_JIS" =+      TL.pack . Enc.decodeLazyByteString Enc.ShiftJIS+  | encodingSymbol == "Windows-31J" =+      TL.pack . Enc.decodeLazyByteString Enc.CP932+  | otherwise =+      LE.decodeUtf8With EE.lenientDecode+decoderForCharset Nothing = LE.decodeUtf8With EE.lenientDecode++decodeForContentType :: ContentType -> L.ByteString -> Maybe TL.Text+decodeForContentType ct bytes = do+  let (t, params) =+        NWP.parseContentType ct+      charset =+        lookup "charset" params+      typeIsText =+        B.isPrefixOf "text" t+            || B.isPrefixOf "application/json" t+            || B.isPrefixOf "application/rss"  t+            || B.isPrefixOf "application/atom" t+      decoder = decoderForCharset charset+  void charset <|> guard typeIsText+  pure $ decoder bytes++contentToSnippet :: Content -> I.Int64 -> Maybe L.ByteString+contentToSnippet (ContentBuilder builder maybeLength) maxLength =+  pure $ truncatedText <> excessLengthMsg+  where+    truncatedText = L.take maxLength $ BB.toLazyByteString builder+    excessLength = fromMaybe 0 $ (subtract $ fromIntegral maxLength) <$> maybeLength+    excessLengthMsg = case excessLength > 0 of+      False -> ""+      True -> "...+ " <> BB.toLazyByteString (BB.intDec excessLength)+contentToSnippet (ContentSource _) _ = Nothing+contentToSnippet (ContentFile _ _) _ = Nothing+contentToSnippet (ContentDontEvaluate _) _ = Nothing++-- | Represents TypedContent as a String, rendering at most a specified number of+-- bytes of the content, and annotating it with the remaining length. Returns Nothing+-- if the content type indicates the content is binary data.+--+-- @since 1.6.28.0+typedContentToSnippet :: TypedContent -> I.Int64 -> Maybe TL.Text+typedContentToSnippet (TypedContent t c) maxLength = decodeForContentType t =<< contentToSnippet c maxLength
+ src/Yesod/Core/Unsafe.hs view
@@ -0,0 +1,25 @@+-- | This is designed to be used as+--+-- > import qualified Yesod.Core.Unsafe as Unsafe+--+-- This serves as a reminder that the functions are unsafe to use in many situations.+module Yesod.Core.Unsafe (runFakeHandler, fakeHandlerGetLogger) where++import Yesod.Core.Internal.Run (runFakeHandler)++import Yesod.Core.Types+import Yesod.Core.Class.Yesod+import Control.Monad.IO.Class (MonadIO)++-- | designed to be used as+--+-- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger+fakeHandlerGetLogger :: (Yesod site, MonadIO m)+                     => (site -> Logger)+                     -> site+                     -> HandlerFor site a+                     -> m a+fakeHandlerGetLogger getLogger app f =+     runFakeHandler mempty getLogger app f+ >>= either (error . ("runFakeHandler issue: " `mappend`) . show)+            return
+ src/Yesod/Core/Widget.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier+-- generator, allowing you to create truly modular HTML components.+module Yesod.Core.Widget+    ( -- * Datatype+      WidgetT+    , WidgetFor+    , PageContent (..)+      -- * Special Hamlet quasiquoter/TH for Widgets+    , whamlet+    , whamletFile+    , ihamletToRepHtml+    , ihamletToHtml+      -- * Convert to Widget+    , ToWidget (..)+    , ToWidgetHead (..)+    , ToWidgetBody (..)+    , ToWidgetMedia (..)+      -- * Creating+      -- ** Head of page+    , setTitle+    , setTitleI+    , setDescription+    , setDescriptionI+    , setDescriptionIdemp+    , setDescriptionIdempI+    , setOGType+    , setOGImage+      -- ** CSS+    , addStylesheet+    , addStylesheetAttrs+    , addStylesheetRemote+    , addStylesheetRemoteAttrs+    , addStylesheetEither+    , CssBuilder (..)+      -- ** Javascript+    , addScript+    , addScriptAttrs+    , addScriptRemote+    , addScriptRemoteAttrs+    , addScriptEither+      -- * Subsites+    , handlerToWidget+      -- * Internal+    , whamletFileWithSettings+    , asWidgetT+    ) where++import Data.Monoid (Last (..))+import qualified Text.Blaze.Html5 as H+import Text.Hamlet+import Text.Cassius+import Text.Julius+import Yesod.Routes.Class+import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)+import Text.Shakespeare.I18N (RenderMessage)+import Data.Text (Text)+import Data.Kind (Type)+import qualified Data.Map as Map+import Language.Haskell.TH.Quote (QuasiQuoter)+import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)++import qualified Text.Hamlet as NP+import Data.Text.Lazy.Builder (fromLazyText)+import Text.Blaze.Html (toHtml, preEscapedToMarkup)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB++import Yesod.Core.Types+import Yesod.Core.Class.Handler++type WidgetT site (m :: Type -> Type) = WidgetFor site+{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}++preEscapedLazyText :: TL.Text -> Html+preEscapedLazyText = preEscapedToMarkup++class ToWidget site a where+    toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()++instance render ~ RY site => ToWidget site (render -> Html) where+    toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty mempty+instance render ~ RY site => ToWidget site (render -> Css) where+    toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x+instance ToWidget site Css where+    toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x+instance render ~ RY site => ToWidget site (render -> CssBuilder) where+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty+instance ToWidget site CssBuilder where+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty+instance render ~ RY site => ToWidget site (render -> Javascript) where+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just x) mempty+instance ToWidget site Javascript where+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just $ const x) mempty+instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where+    toWidget = liftWidget+instance ToWidget site Html where+    toWidget = toWidget . const+-- | @since 1.4.28+instance ToWidget site Text where+    toWidget = toWidget . toHtml+-- | @since 1.4.28+instance ToWidget site TL.Text where+    toWidget = toWidget . toHtml+-- | @since 1.4.28+instance ToWidget site TB.Builder where+    toWidget = toWidget . toHtml++-- | Allows adding some CSS to the page with a specific media type.+--+-- Since 1.2+class ToWidgetMedia site a where+    -- | Add the given content to the page, but only for the given media type.+    --+    -- Since 1.2+    toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site)+                  => Text -- ^ media value+                  -> a+                  -> m ()+instance render ~ RY site => ToWidgetMedia site (render -> Css) where+    toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x+instance ToWidgetMedia site Css where+    toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x+instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where+    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty+instance ToWidgetMedia site CssBuilder where+    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty++class ToWidgetBody site a where+    toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()++instance render ~ RY site => ToWidgetBody site (render -> Html) where+    toWidgetBody = toWidget+instance render ~ RY site => ToWidgetBody site (render -> Javascript) where+    toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j+instance ToWidgetBody site Javascript where+    toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j+instance ToWidgetBody site Html where+    toWidgetBody = toWidget++class ToWidgetHead site a where+    toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()++instance render ~ RY site => ToWidgetHead site (render -> Html) where+    toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty mempty . Head+instance render ~ RY site => ToWidgetHead site (render -> Css) where+    toWidgetHead = toWidget+instance ToWidgetHead site Css where+    toWidgetHead = toWidget+instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where+    toWidgetHead = toWidget+instance ToWidgetHead site CssBuilder where+    toWidgetHead = toWidget+instance render ~ RY site => ToWidgetHead site (render -> Javascript) where+    toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j+instance ToWidgetHead site Javascript where+    toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j+instance ToWidgetHead site Html where+    toWidgetHead = toWidgetHead . const++-- | Set the page title.+--+-- Calling @setTitle@ or @setTitleI@ multiple times overrides previously set+-- values.+--+-- SEO Notes:+--+--    * Title tags are the second most important on-page factor for SEO, after+--      content+--    * Every page should have a unique title tag+--    * Start your title tag with your main targeted keyword+--    * Don't stuff your keywords+--    * Google typically shows 55-64 characters, so aim to keep your title+--      length under 60 characters+setTitle :: MonadWidget m => Html -> m ()+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty++-- | Set the localised page title.+--+-- n.b. See comments for @setTitle@+setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()+setTitleI msg = do+    mr <- getMessageRender+    setTitle $ toHtml $ mr msg++-- | Add description meta tag to the head of the page+--+-- Google does not use the description tag as a ranking signal, but the+-- contents of this tag will likely affect your click-through rate since it+-- shows up in search results.+--+-- The average length of the description shown in Google's search results is+-- about 160 characters on desktop, and about 130 characters on mobile, at time+-- of writing.+--+-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/+--+-- @since 1.6.18+setDescription :: MonadWidget m => Text -> m ()+setDescription description =+    toWidgetHead $ [hamlet|<meta name=description content=#{description}>|]++{-# WARNING setDescription+  [ "setDescription is not idempotent; we recommend setDescriptionIdemp instead"+  , "Multiple calls to setDescription will insert multiple meta tags in the page head."+  , "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \+    \may need to change your layout to include pageDescription."+  ]+#-}++-- | Add translated description meta tag to the head of the page+--+-- n.b. See comments for @setDescription@.+--+-- @since 1.6.18+setDescriptionI+  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)+  => msg -> m ()+setDescriptionI msg = do+    mr <- getMessageRender+    toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|]++{-# WARNING setDescriptionI+  [ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead"+  , "Multiple calls to setDescriptionI will insert multiple meta tags in the page head."+  , "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \+    \may need to change your layout to include pageDescription."+  ]+#-}++-- | Add description meta tag to the head of the page+--+-- Google does not use the description tag as a ranking signal, but the+-- contents of this tag will likely affect your click-through rate since it+-- shows up in search results.+--+-- The average length of the description shown in Google's search results is+-- about 160 characters on desktop, and about 130 characters on mobile, at time+-- of writing.+--+-- Unlike 'setDescription', this version is *idempotent* - calling it multiple+-- times will result in only a single description meta tag in the head.+--+-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/+--+-- @since 1.6.23+setDescriptionIdemp :: MonadWidget m => Text -> m ()+setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty++-- | Add translated description meta tag to the head of the page+--+-- n.b. See comments for @setDescriptionIdemp@.+--+-- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple+-- times will result in only a single description meta tag in the head.+--+-- @since 1.6.23+setDescriptionIdempI+  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)+  => msg -> m ()+setDescriptionIdempI msg = do+    mr <- getMessageRender+    setDescriptionIdemp $ mr msg++-- | Add OpenGraph type meta tag to the head of the page+--+-- See all available OG types here: https://ogp.me/#types+--+-- @since 1.6.18+setOGType :: MonadWidget m => Text -> m ()+setOGType a = toWidgetHead $ [hamlet|<meta property="og:type" content=#{a}>|]++-- | Add OpenGraph image meta tag to the head of the page+--+-- Best practices:+--+--    * Use custom images for shareable pages, e.g., homepage, articles, etc.+--    * Use your logo or any other branded image for the rest of your pages.+--    * Use images with a 1.91:1 ratio and minimum recommended dimensions of+--      1200x630 for optimal clarity across all devices.+--+-- Source: https://ahrefs.com/blog/open-graph-meta-tags/+--+-- @since 1.6.18+setOGImage :: MonadWidget m => Text -> m ()+setOGImage a = toWidgetHead $ [hamlet|<meta property="og:image" content=#{a}>|]++-- | Link to the specified local stylesheet.+addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()+addStylesheet = flip addStylesheetAttrs []++-- | Link to the specified local stylesheet.+addStylesheetAttrs :: MonadWidget m+                   => Route (HandlerSite m)+                   -> [(Text, Text)]+                   -> m ()+addStylesheetAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty++-- | Link to the specified remote stylesheet.+addStylesheetRemote :: MonadWidget m => Text -> m ()+addStylesheetRemote = flip addStylesheetRemoteAttrs []++-- | Link to the specified remote stylesheet.+addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()+addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty++addStylesheetEither :: MonadWidget m+                    => Either (Route (HandlerSite m)) Text+                    -> m ()+addStylesheetEither = either addStylesheet addStylesheetRemote++addScriptEither :: MonadWidget m+                => Either (Route (HandlerSite m)) Text+                -> m ()+addScriptEither = either addScript addScriptRemote++-- | Link to the specified local script.+addScript :: MonadWidget m => Route (HandlerSite m) -> m ()+addScript = flip addScriptAttrs []++-- | Link to the specified local script.+addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()+addScriptAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty++-- | Link to the specified remote script.+addScriptRemote :: MonadWidget m => Text -> m ()+addScriptRemote = flip addScriptRemoteAttrs []++-- | Link to the specified remote script.+addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()+addScriptRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty++whamlet :: QuasiQuoter+whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings++whamletFile :: FilePath -> Q Exp+whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings++whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp+whamletFileWithSettings = NP.hamletFileWithSettings rules++asWidgetT :: WidgetT site m () -> WidgetT site m ()+asWidgetT = id++rules :: Q NP.HamletRules+rules = do+    ah <- [|asWidgetT . toWidget|]+    let helper qg f = do+            x <- newName "urender"+            e <- f $ VarE x+            let e' = LamE [VarP x] e+            g <- qg+            bind <- [|(>>=)|]+            return $ InfixE (Just g) bind (Just e')+    let ur f = do+            let env = NP.Env+                    (Just $ helper [|getUrlRenderParams|])+                    (Just $ helper [|fmap (toHtml .) getMessageRender|])+            f env+    return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b++-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.+ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)+                 => HtmlUrlI18n message (Route (HandlerSite m))+                 -> m Html+ihamletToRepHtml = ihamletToHtml+{-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-}++-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.+--+-- Since 1.2.1+ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)+              => HtmlUrlI18n message (Route (HandlerSite m))+              -> m Html+ihamletToHtml ih = do+    urender <- getUrlRenderParams+    mrender <- getMessageRender+    return $ ih (toHtml . mrender) urender++tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()+tell = liftWidget . tellWidget++toUnique :: x -> UniqueList x+toUnique = UniqueList . (:)++handlerToWidget :: HandlerFor site a -> WidgetFor site a+handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler
+ src/Yesod/Routes/Class.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Yesod.Routes.Class+    ( RenderRoute (..)+    , ParseRoute (..)+    , RouteAttrs (..)+    , -- * For nested routes and splitting files+      RenderRouteNested (..)+    , ParseRouteNested (..)+    , RouteAttrsNested (..)+    , WithParentArgs (..)+    ) where++import Data.Text (Text)+import Data.Set (Set)+import Data.Kind (Type)++class Eq (Route a) => RenderRoute a where+    -- | The <http://www.yesodweb.com/book/routing-and-handlers type-safe URLs> associated with a site argument.+    data Route a+    renderRoute :: Route a+                -> ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value.++-- | This datatype wraps up the 'ParentArgs' for a route fragment with the+-- route fragment itself. A route fragment with its parent arguments can+-- be rendered and dispatched on.+--+-- @since 1.7.0.0+data WithParentArgs a = WithParentArgs+    { theParentArgs :: ParentArgs a+    , parentArgsFor :: a+    }++deriving stock instance (Eq (ParentArgs a), Eq a) => Eq (WithParentArgs a)++instance (Eq (ParentArgs a), RenderRouteNested a) => RenderRouteNested (WithParentArgs a) where+    type ParentSite (WithParentArgs a) = ParentSite a+    type ParentArgs (WithParentArgs a) = ()++    renderRouteNested () (WithParentArgs parentArgs a) =+        renderRouteNested parentArgs a++-- | This class acts as a delegation class for 'RenderRoute' on nested+-- route fragments.+--+-- @since 1.7.0.0+class Eq a => RenderRouteNested a where+    -- | The site type for a given route fragment.+    --+    -- @since 1.7.0.0+    type ParentSite a :: Type++    -- | The 'ParentArgs' are the route fragments necessary to call the+    -- dispatched route that are not part of the route fragments used in+    -- parsing the route.+    --+    -- @since 1.7.0.0+    type ParentArgs a :: Type+    type ParentArgs a = ()++    -- | Render the fragment of the route. To form a complete route, you'll+    -- need to 'mappend' this with the result from the parent 'renderRoute'+    -- or 'renderRouteNested' call.+    --+    -- @since 1.7.0.0+    renderRouteNested :: ParentArgs a -> a -> ([Text], [(Text, Text)])++instance (RenderRoute site) => RenderRouteNested (Route site) where+    type ParentSite (Route site) = site+    type ParentArgs (Route site) = ()++    renderRouteNested () a = renderRoute a++class RenderRoute a => ParseRoute a where+    parseRoute :: ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value.+               -> Maybe (Route a)++-- | Like 'RenderRouteNested', this acts as a delegation class for nested+-- route fragments.+--+-- Note that 'parseRouteNested' and 'renderRouteNested' are /not/ inverses, by+-- design. 'renderRouteNested' consumes the @'ParentArgs' a@ (the parent's+-- dynamic pieces) to produce a complete path, whereas 'parseRouteNested'+-- recovers only the fragment @a@ and never the 'ParentArgs' — the parent is+-- responsible for those. So @'parseRouteNested' p@ followed by+-- @'renderRouteNested' args@ round-trips the /fragment/ portion of @p@ only,+-- with @args@ supplied separately by the caller.+--+-- @since 1.7.0.0+class RenderRouteNested a => ParseRouteNested a where+    -- | Parse a route fragment from a path. Like 'parseRoute', but produces+    -- the fragment @a@ directly rather than a complete 'Route'; the parent is+    -- responsible for constructing the full route from the result.+    --+    -- @since 1.7.0.0+    parseRouteNested+        :: ([Text], [(Text, Text)])+        -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value.+        --+        -- Unlike for 'parseRoute', this will not include URL fragments as+        -- part of parent routes. It is expected that parents will take the+        -- resulting @a@ and construct the parent from that.+        -> Maybe a++class RenderRoute a => RouteAttrs a where+    routeAttrs :: Route a+               -> Set Text -- ^ A set of <http://www.yesodweb.com/book/route-attributes attributes associated with the route>.++-- | Like 'RenderRouteNested', this acts as a delegation class for nested+-- route fragments to provide 'RouteAttrs'.+--+-- @since 1.7.0.0+class RenderRouteNested a => RouteAttrsNested a where+    -- | Retrieve the 'RouteAttrs' for a given route fragment.+    --+    -- @since 1.7.0.0+    routeAttrsNested :: a -> Set Text
+ src/Yesod/Routes/Overlap.hs view
@@ -0,0 +1,96 @@+-- | Check for overlapping routes.+module Yesod.Routes.Overlap+    ( findOverlapNames+    , Overlap (..)+    ) where++import Yesod.Routes.TH.Types+import Data.List (intercalate)++data Flattened t = Flattened+    { fNames :: [String]+    , fPieces :: [Piece t]+    , fHasSuffix :: Bool+    , fCheck :: CheckOverlap+    }++flatten :: ResourceTree t -> [Flattened t]+flatten =+    go id id True+  where+    go names pieces check (ResourceLeaf r) = return Flattened+        { fNames = names [resourceName r]+        , fPieces = pieces (resourcePieces r)+        , fHasSuffix = hasSuffix $ ResourceLeaf r+        , fCheck = check && resourceCheck r+        }+    go names pieces check (ResourceParent newname check' _attrs newpieces children) =+        concatMap (go names' pieces' (check && check')) children+      where+        names' = names . (newname:)+        pieces' = pieces . (newpieces ++)++data Overlap t = Overlap+    { overlapParents :: [String] -> [String] -- ^ parent resource trees+    , overlap1 :: ResourceTree t+    , overlap2 :: ResourceTree t+    }++data OverlapF = OverlapF+    { _overlapF1 :: [String]+    , _overlapF2 :: [String]+    }++overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool++-- No pieces on either side, will overlap regardless of suffix+overlaps [] [] _ _ = True++-- No pieces on the left, will overlap if the left side has a suffix+overlaps [] _ suffixX _ = suffixX++-- Ditto for the right+overlaps _ [] _ suffixY = suffixY++-- Compare the actual pieces+overlaps (pieceX:xs) (pieceY:ys) suffixX suffixY =+    piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY++piecesOverlap :: Piece t -> Piece t -> Bool+-- Statics only match if they are equal. A dynamic piece is treated as+-- overlapping with anything: although at runtime a typed dynamic (e.g. an+-- 'Int') only matches inputs that parse to its type, the overlap check is+-- intentionally conservative and never inspects the dynamic-piece type — it is+-- parametric in @t@ (see 'findOverlapNames'). Reporting a possible overlap that+-- cannot actually occur is harmless; missing a real one would not be.+piecesOverlap (Static x) (Static y) = x == y+piecesOverlap _ _ = True++-- | The overlap check never inspects the dynamic-piece type, so this is+-- parametric in it (the reported names come from 'resourceName', always a+-- 'String').+findOverlapNames :: [ResourceTree t] -> [(String, String)]+findOverlapNames =+    map go . findOverlapsF . filter fCheck . concatMap Yesod.Routes.Overlap.flatten+  where+    go (OverlapF x y) =+        (go' x, go' y)+      where+        go' = intercalate "/"++findOverlapsF :: [Flattened t] -> [OverlapF]+findOverlapsF [] = []+findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs++findOverlapF :: Flattened t -> Flattened t -> [OverlapF]+findOverlapF x y+    | overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)]+    | otherwise = []++hasSuffix :: ResourceTree t -> Bool+hasSuffix (ResourceLeaf r) =+    case resourceDispatch r of+        Subsite{} -> True+        Methods Just{} _ -> True+        Methods Nothing _ -> False+hasSuffix ResourceParent{} = True
+ src/Yesod/Routes/Parse.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter++module Yesod.Routes.Parse+    ( parseRoutes+    , parseRoutesFile+    , parseRoutesNoCheck+    , parseRoutesFileNoCheck+    , parseType+    , parseTypeM+    , parseTypeTree+    , TypeTree (..)+    , dropBracket+    , dropBracketM+    , nameToType+    , isTvar+    ) where++import Language.Haskell.TH.Syntax+import Data.Char (isUpper, isLower, isSpace)+import Language.Haskell.TH.Quote+import qualified System.IO as SIO+import Yesod.Routes.TH+import Yesod.Routes.Overlap (findOverlapNames)+import Data.List (foldl', isPrefixOf)+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set++-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for+-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the+-- checking. See documentation site for details on syntax.+parseRoutes :: QuasiQuoter+parseRoutes = QuasiQuoter { quoteExp = x }+  where+    x s = do+        res <- resourcesFromString s+        case findOverlapNames res of+            [] -> lift res+            z -> fail $ unlines $ "Overlapping routes: " : map show z++-- | Same as 'parseRoutes', but uses an external file instead of quasiquotation.+--+-- The recommended file extension is @.yesodroutes@.+parseRoutesFile :: FilePath -> Q Exp+parseRoutesFile = parseRoutesFileWith parseRoutes++-- | Same as 'parseRoutesNoCheck', but uses an external file instead of quasiquotation.+--+-- The recommended file extension is @.yesodroutes@.+parseRoutesFileNoCheck :: FilePath -> Q Exp+parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck++parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp+parseRoutesFileWith qq fp = do+    qAddDependentFile fp+    s <- qRunIO $ readUtf8File fp+    quoteExp qq s++readUtf8File :: FilePath -> IO String+readUtf8File fp = do+    h <- SIO.openFile fp SIO.ReadMode+    SIO.hSetEncoding h SIO.utf8_bom+    SIO.hGetContents h++-- | Same as 'parseRoutes', but performs no overlap checking.+parseRoutesNoCheck :: QuasiQuoter+parseRoutesNoCheck = QuasiQuoter+    { quoteExp = \s -> resourcesFromString s >>= lift+    }++-- | Converts a multi-line string to a set of resources. See documentation for+-- the format of this string. Runs in any 'MonadFail' (e.g. the 'Q' monad of a+-- splice) and reports malformed input through 'fail', so diagnostics are+-- attributed to the splice rather than surfacing as a raw 'error' call stack.+resourcesFromString :: MonadFail m => String -> m [ResourceTree String]+resourcesFromString =+    fmap fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r')+  where+    parse _ [] = pure ([], [])+    parse indent (thisLine:otherLines)+        | length spaces < indent = pure ([], thisLine : otherLines)+        | otherwise = do+            (this, otherLines') <- classify+            (others, remainder) <- parse indent otherLines'+            pure (this others, remainder)+      where+        parseAttr ('!':x) = Just x+        parseAttr _ = Nothing++        stripColonLast =+            go id+          where+            go _ [] = Nothing+            go front [x]+                | null x = Nothing+                | last x == ':' = Just $ front [init x]+                | otherwise = Nothing+            go front (x:xs) = go (front . (x:)) xs++        spaces = takeWhile (== ' ') thisLine+        classify = do+            toks <- splitSpaces thisLine+            case takeWhile (not . isPrefixOf "--") toks of+                (pattern:rest0)+                    | Just (constr:rest) <- stripColonLast rest0+                    , Just attrs <- mapM parseAttr rest -> do+                        (children, otherLines'') <- parse (length spaces + 1) otherLines+                        let children' = addAttrs attrs children+                        (pieces, mmulti, check) <- piecesFromStringCheck pattern+                        case mmulti of+                            Nothing -> pure ()+                            Just _ -> fail $ "Parent routes cannot have a multipiece: " ++ pattern+                        pure ((ResourceParent constr check (Set.fromList attrs) pieces children' :), otherLines'')+                (pattern:constr:rest) -> do+                    (pieces, mmulti, check) <- piecesFromStringCheck pattern+                    let (attrs, rest') = takeAttrs rest+                    disp <- dispatchFromString rest' mmulti+                    pure ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines)+                [] -> pure (id, otherLines)+                _ -> fail $ "Invalid resource line: " ++ thisLine++-- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive).+splitSpaces :: MonadFail m => String -> m [String]+splitSpaces "" = pure []+splitSpaces str = do+    (rest, piece) <- parse $ dropWhile isSpace str+    rest' <- splitSpaces rest+    pure (piece : rest')++    where+        parse ('{':s) = do (r, p) <- parseBracket s; pure (r, '{':p)+        parse (c:s) | isSpace c = pure (s, [])+        parse (c:s) = do (r, p) <- parse s; pure (r, c:p)+        parse "" = pure ("", "")++        parseBracket ('{':_) = fail $ "Invalid resource line (nested curly bracket): " ++ str+        parseBracket ('}':s) = do (r, p) <- parse s; pure (r, '}':p)+        parseBracket (c:s) = do (r, p) <- parseBracket s; pure (r, c:p)+        parseBracket "" = fail $ "Invalid resource line (unclosed curly bracket): " ++ str++piecesFromStringCheck :: MonadFail m => String -> m ([Piece String], Maybe String, Bool)+piecesFromStringCheck s0 = do+    let (s1, check1) = stripBang s0+    (pieces', mmulti') <- piecesFromString $ drop1Slash s1+    let pieces = map snd pieces'+        mmulti = fmap snd mmulti'+        check = check1 && all fst pieces' && maybe True fst mmulti'+    pure (pieces, mmulti, check)+  where+    stripBang ('!':rest) = (rest, False)+    stripBang x = (x, True)++addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String]+addAttrs attrs =+    map goTree+  where+    goTree (ResourceLeaf res) = ResourceLeaf (goRes res)+    goTree (ResourceParent v w x y z) = ResourceParent v w x y (map goTree z)++    goRes res =+        res { resourceAttrs = noDupes ++ resourceAttrs res }+      where+        usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res+        used attr =+            case toPair attr of+                Nothing -> False+                Just (key, _) -> key `Set.member` usedKeys+        noDupes = filter (not . used) attrs++    toPair s =+        case break (== '=') s of+            (x, '=':y) -> Just (x, y)+            _ -> Nothing++-- | Take attributes out of the list and put them in the first slot in the+-- result tuple.+takeAttrs :: [String] -> ([String], [String])+takeAttrs =+    go id id+  where+    go x y [] = (x [], y [])+    go x y (('!':attr):rest) = go (x . (attr:)) y rest+    go x y (z:rest) = go x (y . (z:)) rest++dispatchFromString :: MonadFail m => [String] -> Maybe String -> m (Dispatch String)+dispatchFromString rest mmulti+    | null rest = pure $ Methods mmulti []+    | all (all isUpper) rest = pure $ Methods mmulti rest+dispatchFromString [subTyp, subFun] Nothing =+    pure $ Subsite subTyp subFun+dispatchFromString [_, _] Just{} =+    fail "Subsites cannot have a multipiece"+dispatchFromString rest _ = fail $ "Invalid list of methods: " ++ show rest++drop1Slash :: String -> String+drop1Slash ('/':x) = x+drop1Slash x = x++piecesFromString :: MonadFail m => String -> m ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String))+piecesFromString "" = pure ([], Nothing)+piecesFromString x = do+    rest <- piecesFromString $ drop 1 z+    this <- pieceFromString y+    case (this, rest) of+        (Left typ, ([], Nothing)) -> pure ([], Just typ)+        (Left _, _) -> fail "Multipiece must be last piece"+        (Right piece, (pieces, mtyp)) -> pure (piece:pieces, mtyp)+  where+    (y, z) = break (== '/') x++parseType :: String -> Type+parseType orig =+    maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig++-- | 'parseType' in 'MonadFail': a malformed type surfaces via 'fail' instead of+-- a raw 'error'. Used at the 'Language.Haskell.TH.Q' splice sites so a bad type+-- in a route definition becomes an attributed compile error. The pure+-- 'parseType' is retained for callers (e.g. tests) supplying known-good input.+--+-- @since 1.7.0.0+parseTypeM :: MonadFail m => String -> m Type+parseTypeM orig =+    maybe (fail $ "Invalid type: " ++ show orig) (pure . ttToType) $ parseTypeTree orig++parseTypeTree :: String -> Maybe TypeTree+parseTypeTree orig =+    toTypeTree pieces+  where+    pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig+    addDashes [] = []+    addDashes (x:xs) =+        front $ addDashes xs+      where+        front rest+            | x `elem` "()[]" = '-' : x : '-' : rest+            | otherwise = x : rest+    splitOn c s =+        case y' of+            _:y -> x : splitOn c y+            [] -> [x]+      where+        (x, y') = break c s++data TypeTree = TTTerm String+              | TTApp TypeTree TypeTree+              | TTList TypeTree+    deriving (Show, Eq)++toTypeTree :: [String] -> Maybe TypeTree+toTypeTree orig = do+    (x, []) <- gos orig+    return x+  where+    go [] = Nothing+    go ("(":xs) = do+        (x, rest) <- gos xs+        case rest of+            ")":rest' -> Just (x, rest')+            _ -> Nothing+    go ("[":xs) = do+        (x, rest) <- gos xs+        case rest of+            "]":rest' -> Just (TTList x, rest')+            _ -> Nothing+    go (x:xs) = Just (TTTerm x, xs)++    gos xs1 = do+        (t, xs2) <- go xs1+        (ts, xs3) <- gos' id xs2+        Just (foldl' TTApp t ts, xs3)++    gos' front [] = Just (front [], [])+    gos' front (x:xs)+        | x `elem` words ") ]" = Just (front [], x:xs)+        | otherwise = do+            (t, xs') <- go $ x:xs+            gos' (front . (t:)) xs'++ttToType :: TypeTree -> Type+ttToType (TTTerm s) = fst $ nameToType s+ttToType (TTApp x y) = ttToType x `AppT` ttToType y+ttToType (TTList t) = ListT `AppT` ttToType t++nameToType :: String -> (Type, Name)+nameToType t = (, nm) $ if isTvar t+               then VarT nm+               else ConT nm+    where nm = mkName t++isTvar :: String -> Bool+isTvar (h:_) = isLower h+isTvar _     = False++-- | 'MonadFail' so that an unclosed bracket in a 'Dynamic' piece (via+-- 'dropBracketM') surfaces as an attributed splice error rather than a raw+-- 'error' (the pure 'dropBracket' would otherwise bottom out deep in codegen).+pieceFromString :: MonadFail m => String -> m (Either (CheckOverlap, String) (CheckOverlap, Piece String))+pieceFromString ('#':'!':x) = Right . (False,) . Dynamic <$> dropBracketM x+pieceFromString ('!':'#':x) = Right . (False,) . Dynamic <$> dropBracketM x -- https://github.com/yesodweb/yesod/issues/652+pieceFromString ('#':x) = Right . (True,) . Dynamic <$> dropBracketM x++pieceFromString ('*':'!':x) = pure $ Left (False, x)+pieceFromString ('+':'!':x) = pure $ Left (False, x)++pieceFromString ('!':'*':x) = pure $ Left (False, x)+pieceFromString ('!':'+':x) = pure $ Left (False, x)++pieceFromString ('*':x) = pure $ Left (True, x)+pieceFromString ('+':x) = pure $ Left (True, x)++pieceFromString ('!':x) = pure $ Right (False, Static x)+pieceFromString x = pure $ Right (True, Static x)++dropBracket :: String -> String+dropBracket str@('{':x) = case break (== '}') x of+    (s, "}") -> s+    _ -> error $ "Unclosed bracket ('{'): " ++ str+dropBracket x = x++-- | 'dropBracket' in 'MonadFail': an unclosed @{@ surfaces via 'fail' instead+-- of a raw 'error', so it becomes an attributed compile error at a splice site.+--+-- @since 1.7.0.0+dropBracketM :: MonadFail m => String -> m String+dropBracketM str@('{':x) = case break (== '}') x of+    (s, "}") -> pure s+    _ -> fail $ "Unclosed bracket ('{'): " ++ str+dropBracketM x = pure x++-- | If this line ends with a backslash, concatenate it together with the next line.+--+-- @since 1.6.8+lineContinuations :: String -> [String] -> [String]+lineContinuations this [] = [this]+lineContinuations this below@(next:rest) = case unsnoc this of+    Just (this', '\\') -> (this' ++ next):rest+    _ -> this:below+  where unsnoc s = if null s then Nothing else Just (init s, last s)
+ src/Yesod/Routes/TH.hs view
@@ -0,0 +1,44 @@+module Yesod.Routes.TH+    ( module Yesod.Routes.TH.Types+      -- * Functions+    , -- ** RenderRoute+      mkRenderRouteInstanceOpts+    , mkRouteConsOpts+    , shouldCreateResources++    , RouteOpts+    , defaultOpts+    , setEqDerived+    , setShowDerived+    , setReadDerived+    , setFocusOnNestedRoute+    , unsetFocusOnNestedRoute+    , roFocusOnNestedRoute+    , roNestedRouteFallthrough+    , setCreateResources+    , setParameterizedSubroute+    , setNestedRouteFallthrough+    , DiscoveryMode(..)+    , discoveryMode+    , module Yesod.Routes.TH.ParseRoute+    , module Yesod.Routes.TH.RouteAttrs+      -- ** Dispatch+    , MkDispatchSettings (..)+    , mkDispatchClause+    , defaultGetHandler+    , SDC(..)+    , mkDispatchInstance+    , mkNestedDispatchInstance+    , mkNestedDispatchInstanceWith+    , NestedTarget (..)+    , mkMDS+    , mkYesodSubDispatch+    , mkYesodSubDispatchWith+    , subTopDispatch+    ) where++import Yesod.Routes.TH.Types+import Yesod.Routes.TH.RenderRoute+import Yesod.Routes.TH.ParseRoute+import Yesod.Routes.TH.RouteAttrs+import Yesod.Routes.TH.Dispatch
+ src/Yesod/Routes/TH/Dispatch.hs view
@@ -0,0 +1,1054 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}++module Yesod.Routes.TH.Dispatch+    ( MkDispatchSettings (..)+    , mkDispatchClause+    , defaultGetHandler+    , SDC(..)+    , mkDispatchInstance+    , mkNestedDispatchInstance+    , mkNestedDispatchInstanceWith+    , NestedTarget (..)+    , SameSpliceNestedInstances (..)+    , mkMDS+    , mkYesodSubDispatch+    , mkYesodSubDispatchWith+    , mkYesodSubDispatchWithDelegate+    , subTopDispatch+    , parseYesodName+    ) where++import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)+import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)+import Data.Maybe+import Data.Proxy (Proxy(..))+import Yesod.Routes.TH.RenderRoute+import qualified Network.Wai as W+import Yesod.Core.Content (ToTypedContent (..))+import Language.Haskell.TH hiding (cxt, instanceD)+import Yesod.Core.Types hiding (Body)+import Yesod.Core.Class.Dispatch+import Prelude hiding (exp)+import Yesod.Routes.TH.Internal+import Control.Monad+import Control.Monad.Reader (ReaderT, runReaderT, asks, local, lift)+import Data.List (foldl')+import Yesod.Routes.TH.Types+import Data.Char (toLower)+import Yesod.Core.Internal.Run+import Yesod.Core.Handler+import Yesod.Core.Class.Dispatch.ToParentRoute (ToParentRoute(..))+import Yesod.Core.Class.Yesod (Yesod)++-- | This datatype describes how to create the dispatch clause for a route+-- path.+data MkDispatchSettings b site c = MkDispatchSettings+    { mdsRunHandler :: Q Exp+    , mdsSubDispatcher :: Q Exp+    , mdsGetPathInfo :: Q Exp+    , mdsSetPathInfo :: Q Exp+    , mdsMethod :: Q Exp+    , mds404 :: Q Exp+    , mds405 :: Q Exp+    , mdsGetHandler :: Maybe String -> String -> Q Exp+    , mdsUnwrapper :: Exp -> Q Exp+    , mdsNestedRouteFallthrough :: !Bool+    -- ^ When 'True', fall through if no route matches (except in the final+    -- case). When 'False', return 404 if the current route clause fails to+    -- match.+    --+    -- @since 1.7.0.0+    , mdsNestedTarget :: NestedTarget+    -- ^ Whether this dispatch is for a top-level site or a subsite. Selects the+    -- nested-dispatch class to probe ('nestedTargetClass') and the+    -- nested-dispatch function to delegate to ('nestedTargetFn'):+    -- 'TopLevelNested' uses @YesodDispatchNested@\/@yesodDispatchNested@,+    -- 'SubsiteNested' uses @YesodSubDispatchNested@\/@yesodSubDispatchNested@.+    --+    -- @since 1.7.0.0+    , mdsSameSpliceNestedInstances :: !SameSpliceNestedInstances+    -- ^ Whether the caller emits the matching per-parent nested-dispatch+    -- instances in the same splice as this flat dispatch body; see+    -- 'SameSpliceNestedInstances' for how this affects a parent clause.+    -- 'mkMDS' defaults to 'NoSameSpliceNestedInstances'.+    --+    -- @since 1.7.0.0+    }++data SDC = SDC+    { extraParams :: [Exp]+    , extraCons :: [Exp]+    , envExp :: Exp+    , reqExp :: Exp+    }++-- | Which phase of clause generation we're in, which is the only thing that+-- decides how a matched result is wrapped (see 'wrapForPhase'). At the top level+-- the dispatch result is returned unwrapped; inside a parent's inline children+-- we generate helper clauses whose enclosing parent must tell a match from a+-- fall-through miss, so the result is wrapped in 'Just'. Generation starts at+-- 'TopLevelPhase' and flips to 'NestedPhase' on the first descent (and never+-- back), so the two phases are a single 'local'.+data DispatchPhase = TopLevelPhase | NestedPhase++-- | How a matched result is wrapped in a given phase. See 'DispatchPhase'.+wrapForPhase :: DispatchPhase -> Exp -> Exp+wrapForPhase TopLevelPhase = id+wrapForPhase NestedPhase = \e -> ConE 'Just `AppE` e++-- | The reader environment threaded through 'mkDispatchClause's clause+-- generator. 'envSdc' is the accumulated dispatch context (extended via 'local'+-- as we descend into a parent's children); 'envPhase' selects how a matched+-- result is wrapped.+data Env = Env+    { envSdc :: SDC+    , envPhase :: DispatchPhase+    }++-- | The monad 'mkDispatchClause's clause generator runs in: 'Q' carrying an+-- 'Env' read through 'MonadReader'. Every helper that needs the dispatch+-- context or the result wrapper takes them from the environment ('asks' /+-- 'local') rather than as arguments; 'liftQ' lifts the concrete-'Q' primitives.+type DispatchM = ReaderT Env Q++-- | Whether nested-route dispatch is being generated for a top-level site or+-- for a subsite. This is the single bit that selects the whole top-vs-subsite+-- plumbing: the dispatch class to probe and the function to delegate to (used+-- by 'MkDispatchSettings' via 'mdsNestedTarget'), and the runner function,+-- dispatch function\/class, and subsite-environment construction used when+-- generating nested-dispatch instances. All of those follow from this enum via+-- the @nestedTarget*@ derivation functions below.+--+-- @since 1.7.0.0+data NestedTarget+    = TopLevelNested+    -- ^ A top-level site: @YesodDispatchNested@\/@yesodDispatchNested@, run via+    -- @yesodRunner@, constructing 'YesodSubRunnerEnv' directly.+    | SubsiteNested+    -- ^ A subsite: @YesodSubDispatchNested@\/@yesodSubDispatchNested@, run via+    -- @subHelper@, composing through the outer 'YesodSubRunnerEnv' (like+    -- 'subTopDispatch').+    deriving (Eq, Show)++-- | Whether the splice emitting a flat dispatch body also generates the+-- matching per-parent nested-dispatch instances (@YesodDispatchNested@ \/+-- @YesodSubDispatchNested@) in the same declaration group.+--+-- @since 1.7.0.0+data SameSpliceNestedInstances+    = GeneratesNestedInstances+    -- ^ The caller emits the per-parent nested instances alongside the flat+    -- dispatch, so a parent clause /delegates/ to its instance even though the+    -- instance does not exist at probe time — GHC resolves it once the whole+    -- declaration group is spliced. This avoids inlining each nested leaf's+    -- dispatch into the flat body /and/ re-emitting it in the per-parent+    -- instance (see 'mkTopLevelDispatchInstance').+    | NoSameSpliceNestedInstances+    -- ^ Only the flat dispatch is emitted. A parent delegates only when its+    -- nested instance already exists (the cross-module split case) and inlines+    -- otherwise — required for standalone entry points like+    -- 'mkYesodSubDispatch', where delegating would reference a missing+    -- instance.+    deriving (Eq, Show)++-- | The nested-dispatch class to probe\/emit for a target:+-- @''YesodDispatchNested@ for top-level, @''YesodSubDispatchNested@ for subsites.+nestedTargetClass :: NestedTarget -> Name+nestedTargetClass TopLevelNested = ''YesodDispatchNested+nestedTargetClass SubsiteNested  = ''YesodSubDispatchNested++-- | The nested-dispatch function to delegate to\/emit for a target:+-- @'yesodDispatchNested@ for top-level, @'yesodSubDispatchNested@ for subsites.+nestedTargetFn :: NestedTarget -> Name+nestedTargetFn TopLevelNested = 'yesodDispatchNested+nestedTargetFn SubsiteNested  = 'yesodSubDispatchNested++-- | The runner function used inside generated nested-dispatch clauses:+-- @'yesodRunner@ for top-level, @'subHelper@ for subsites.+nestedTargetRunner :: NestedTarget -> Name+nestedTargetRunner TopLevelNested = 'yesodRunner+nestedTargetRunner SubsiteNested  = 'subHelper++-- | The 'ArityCallSite' for arity-mismatch error messages: a top-level site is+-- reached through @mkYesod@, a subsite through @mkYesodSubDispatchInstance@.+nestedTargetCallSite :: NestedTarget -> ArityCallSite+nestedTargetCallSite TopLevelNested = TopLevelCall+nestedTargetCallSite SubsiteNested  = SubsiteCall++-- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on+-- view patterns.+--+-- The function returns the dispatch 'Clause' along with a @['String']@ of the+-- names of nested route types that require a delegation instance to be+-- generated. For 'YesodDispatch', those are 'YesodDispatchNested' instances; for+-- the subsite case, 'YesodSubDispatchNested'.+--+-- @since 1.7.0.0 — the leading @[Name]@\/@[Exp]@ parameters were dropped and the+-- result type changed from @Clause@ to @Q ([String], Clause)@.+mkDispatchClause :: forall a b site c. TyArgs -> MkDispatchSettings b site c -> [ResourceTree a] -> Q ([String], Clause)+mkDispatchClause tyargs MkDispatchSettings {..} resources = do+    envName <- newName "env"+    reqName <- newName "req"+    helperName <- newName "dispatchHelper"++    let envE = VarE envName+        reqE = VarE reqName+        helperE = VarE helperName++    clause404' <- mkClause404 envE reqE+    getPathInfo <- mdsGetPathInfo+    let pathInfo = getPathInfo `AppE` reqE++    let sdc = SDC+            { extraParams = []+            , extraCons = []+            , envExp = envE+            , reqExp = reqE+            }+    -- Generate the dispatch clauses. 'go' runs in @'ReaderT' 'Env' Q@: the+    -- top-level call starts at @envPhase = TopLevelPhase@ so the top-level+    -- resources produce the final (unwrapped) dispatch result and report which+    -- parents need a nested-dispatch instance generated. Descending into a+    -- parent's inline children flips @envPhase@ to 'NestedPhase' (via 'local'),+    -- so children are 'Just'-wrapped helper clauses the enclosing parent can+    -- fall through on; their reported names are dropped (only top-level parents+    -- matter).+    let topEnv = Env { envSdc = sdc, envPhase = TopLevelPhase }+    (childNames, clauses) <- mconcat <$> runReaderT (mapM go resources) topEnv++    pure+        ( childNames+        , Clause+            [VarP envName, VarP reqName]+            (NormalB $ helperE `AppE` pathInfo)+            [FunD helperName $ clauses ++ [clause404']]+        )+  where+    -- Lift a concrete-'Q' action (the TH primitives and this package's own+    -- @Q@-typed helpers) into 'DispatchM'.+    liftQ :: Q x -> DispatchM x+    liftQ = lift++    -- The current phase's result wrapper (see 'wrapForPhase').+    askWrap :: DispatchM (Exp -> Exp)+    askWrap = asks (wrapForPhase . envPhase)++    -- Run an action in the scope of a parent's inline children: extend the+    -- accumulated dynamics and parent constructors with this parent's, and flip+    -- to 'NestedPhase'. This single 'local' — entered once at the top→nested+    -- boundary and never undone — is the entire top-vs-nested phase distinction.+    withChildScope :: [Exp] -> Exp -> DispatchM r -> DispatchM r+    withChildScope dyns constr = local $ \e ->+        let sdc = envSdc e+        in e { envSdc = sdc+                 { extraParams = extraParams sdc ++ dyns+                 , extraCons = extraCons sdc ++ [constr]+                 }+             , envPhase = NestedPhase+             }++    -- | Generate the dispatch clauses for a resource tree node, plus the+    -- @['String']@ of parents that need a nested-dispatch instance generated.+    -- Names are reported for every parent here, but only the top-level call+    -- keeps them; the parent arm drops its children's names (the deeper+    -- instances are generated by a separate recursion in+    -- 'mkNestedDispatchInstanceWith').+    go :: ResourceTree a -> DispatchM ([String], [Clause])+    go (ResourceParent name _check _attrs pieces children) = do+        -- Delegate to the child's nested-dispatch instance when one already+        -- exists (the configured class: YesodDispatchNested for top-level,+        -- YesodSubDispatchNested for subsites). This is what makes splitting+        -- a parent's nested routes across modules work. When no such instance+        -- exists — the ordinary single-module case — the check fails and we+        -- inline the children below, so this stays backwards compatible.+        -- 'nestedInstanceExists' is the shared probe: it resolves the name once+        -- and saturates by the child's own reified arity, so it never aborts+        -- the splice (see its haddock).+        instanceExists <-+            liftQ (nestedInstanceExists (nestedTargetClass mdsNestedTarget) =<< resolveRouteCon name)++        -- Delegate to the nested-dispatch instance either when one already+        -- exists (cross-module split) or when the caller will generate it in+        -- this same splice ('mdsSameSpliceNestedInstances'). In the latter case+        -- the instance does not exist at probe time, but GHC resolves it after+        -- the whole declaration group is spliced — so we avoid inlining every+        -- nested leaf's dispatch logic here only to re-emit it in the parent's+        -- 'YesodDispatchNested' instance. We still report the name below so that+        -- instance actually gets generated.+        let delegate =+                instanceExists || mdsSameSpliceNestedInstances == GeneratesNestedInstances++        (pats, dyns) <- liftQ $ handlePiecesM pieces+        restName <- liftQ $ newName "_rest"+        helperName <- liftQ $ newName ("helper" ++ name)+        let helperCall = VarE helperName `AppE` VarE restName+            constr = applyConPieces name dyns++        helperClauses <-+            if delegate+                then do+                    expr <- delegateToNestedInstance name dyns+                    pure [Clause [VarP restName] (NormalB expr) []]+                else do+                    -- Inline dispatch: descend into the children with the+                    -- extended scope and 'Just' wrapping; their reported names+                    -- are dropped (only top-level parents matter).+                    childClauses <-+                        concatMap snd <$> withChildScope dyns constr (mapM go children)+                    pure $ childClauses ++ [Clause [WildP] (NormalB (ConE 'Nothing)) []]++        body <- parentBody helperCall++        -- Report this parent as needing a nested-dispatch instance whenever one+        -- does not already exist — both when we inlined and when we delegated to+        -- a yet-to-be-generated same-splice instance+        -- ('mdsSameSpliceNestedInstances').+        -- Whether the caller acts on this (i.e. actually generates the instance)+        -- is the caller's decision — see 'mkDispatchInstance'.+        pure+            ( [name | not instanceExists]+            , [ Clause+                [mkPathPat (EndRest restName) pats]+                body+                [FunD helperName helperClauses] ]+            )++    go (ResourceLeaf (Resource name pieces dispatch _ _check)) = do+        (pats, dyns) <- liftQ $ handlePiecesM pieces+        (chooseMethod, finalPat) <- handleDispatch name dispatch dyns+        wrap <- askWrap+        let clauseBody = NormalB (wrap chooseMethod)+        pure ([], [Clause [mkPathPat finalPat pats] clauseBody []])++    -- | Delegate body for a parent that already has a nested-dispatch instance:+    -- call the configured nested-dispatch function, passing this route's+    -- dynamics — plus the accumulated parent dynamics from the environment — as+    -- ParentArgs.+    delegateToNestedInstance :: String -> [Exp] -> DispatchM Exp+    delegateToNestedInstance name dyns = do+        sdc <- asks envSdc+        let thisRouteParentArgs = extraParams sdc ++ dyns+        liftQ (nestedDispatchCall (nestedTargetFn mdsNestedTarget) name dyns tyargs sdc thisRouteParentArgs)++    -- | The body of a parent dispatch clause. @helperCall@ runs the parent's+    -- inline helper on the remaining path; per the fallthrough flag we either+    -- fall through on a 'Nothing' (pattern guard) or commit to a 404. The+    -- matched result is run through the current phase's wrapper.+    parentBody :: Exp -> DispatchM Body+    parentBody helperCall = do+        wrap <- askWrap+        if mdsNestedRouteFallthrough+            then liftQ $ mkGuardedBody helperCall (\match' -> pure (wrap (VarE match')))+            else do+                sdc <- asks envSdc+                liftQ $ do+                    matchName <- newName "match"+                    baseNotFoundExp <-+                        [| $(mdsRunHandler) $(mds404) $(pure (envExp sdc)) Nothing $(pure (reqExp sdc)) |]+                    pure $ NormalB $ CaseE helperCall+                        [ Match (conPCompat 'Just [VarP matchName]) (NormalB (wrap (VarE matchName))) []+                        , Match (conPCompat 'Nothing []) (NormalB (wrap baseNotFoundExp)) []+                        ]++    -- | Build the chosen-method expression and final path tail for a leaf,+    -- reading the dispatch context ('extraParams' / 'extraCons' / 'envExp' /+    -- 'reqExp') from the environment.+    handleDispatch :: String -> Dispatch a -> [Exp] -> DispatchM (Exp, PathTail)+    handleDispatch name dispatch' dyns = do+        SDC {..} <- asks envSdc+        liftQ $ case dispatch' of+                Methods multi methods -> do+                    (finalPat, mfinalE) <-+                        case multi of+                            Nothing -> return (EndExact, Nothing)+                            Just _ -> do+                                multiName <- newName "multi"+                                return (EndMulti multiName, Just $ VarE multiName)++                    let dynsMulti =+                            case mfinalE of+                                Nothing -> dyns+                                Just e -> dyns ++ [e]+                        thisRoute = applyConPieces name dynsMulti+                        fullRoute = foldr AppE thisRoute extraCons+                        jroute = ConE 'Just `AppE` fullRoute+                        allDyns = extraParams ++ dynsMulti+                        mkRunExp mmethod = do+                            runHandlerE <- mdsRunHandler+                            handlerE' <- mdsGetHandler mmethod name+                            handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns+                            return $ runHandlerE+                                `AppE` handlerE+                                `AppE` envExp+                                `AppE` jroute+                                `AppE` reqExp++                    func <-+                        case methods of+                            [] -> mkRunExp Nothing+                            _ -> do+                                getMethod <- mdsMethod+                                let methodE = getMethod `AppE` reqExp+                                matches <- forM methods $ \method -> do+                                    exp <- mkRunExp (Just method)+                                    return $ Match (LitP $ StringL method) (NormalB exp) []+                                match405 <- do+                                    runHandlerE <- mdsRunHandler+                                    handlerE <- mds405+                                    let exp = runHandlerE+                                            `AppE` handlerE+                                            `AppE` envExp+                                            `AppE` jroute+                                            `AppE` reqExp+                                    return $ Match WildP (NormalB exp) []+                                return $ CaseE methodE $ matches ++ [match405]++                    return (func, finalPat)++                Subsite _ getSub -> do+                    restPath <- newName "restPath"+                    let allDyns = extraParams ++ dyns+                    sub2 <- mkLambda "sub" $ \sub ->+                        pure $ foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns+                    routeBuilder <- mkLambda "sroute" $ \sroute ->+                        pure $ let thisRoute = applyConPieces name dyns+                               in foldr AppE (AppE thisRoute $ VarE sroute) extraCons+                    exp <-+                        [| $(mdsSubDispatcher)+                            $(mdsRunHandler)+                            $(pure sub2)+                            $(pure routeBuilder)+                            $(pure envExp)+                            ($(mdsSetPathInfo) $(varE restPath) $(pure reqExp)) |]+                    return (exp, EndRest restPath)++    -- The dispatch helper produced by 'mkDispatchClause' is always a terminal+    -- authority (the top-level / subsite entry point), so a final miss commits+    -- to a 404 here. Inline nested helpers built by 'go' under 'withChildScope'+    -- bake their own @Nothing@ fallback at their call site instead.+    mkClause404 envE reqE = do+        exp <- [| $(mdsRunHandler) $(mds404) $(pure envE) Nothing $(pure reqE) |]+        return $ Clause [WildP] (NormalB exp) []++-- | This function generates code to call the nested dispatch function+-- (either 'yesodDispatchNested' or 'yesodSubDispatchNested').+nestedDispatchCall+    :: Name+    -- ^ The dispatch function to call (e.g. 'yesodDispatchNested' or 'yesodSubDispatchNested')+    -> String+    -- ^ The name of the nested route (e.g., "FirstFooR")+    -> [Exp]+    -- ^ The dynamic arguments for this route constructor+    -> TyArgs+    -- ^ Type arguments for parameterized routes+    -> SDC+    -- ^ The accumulated 'SDC'.+    -> [Exp]+    -- ^ The parent dynamic bound variables (for passing as ParentArgs).+    -> Q Exp+nestedDispatchCall dispatchFn routeName routeDyns tyargs sdc parentDyns = do+    routeType <- appliedRouteTypeNamed routeName tyargs+    let wrapper = foldr composeE (applyConPieces routeName routeDyns) (extraCons sdc)+    [| $(varE dispatchFn)+        (Proxy :: Proxy $(pure routeType))+        $(pure $ parentArgsExprFromExps parentDyns)+        $(pure wrapper)+        $(pure $ envExp sdc)+        $(pure $ reqExp sdc)+     |]++-- | Given an 'Exp' which should result in a @'Maybe' a@, does:+--+-- @+--   | Just a <- exp = mkRhs a+-- @+--+mkGuardedBody+    :: Exp+    -- ^ The expression to match Just with+    -> (Name -> Q Exp)+    -- ^ The function to take a 'Name' and create the right hand value on+    -- successful match.+    -> Q Body+mkGuardedBody exp mkRhs = do+    matchName <- newName "match"+    result <- mkRhs matchName+    let patGuard =+            PatG [BindS (conPCompat 'Just [VarP matchName]) exp]+    pure $ GuardedB [(patGuard, result)]++defaultGetHandler :: Maybe String -> String -> Q Exp+defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s+defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s++-- | If the generation of @'YesodDispatch'@ instance require finer+-- control of the types, contexts etc. using this combinator. You will+-- hardly need this generality. However, in certain situations, like+-- when writing library/plugin for yesod, this combinator becomes+-- handy.+mkDispatchInstance+    :: RouteOpts+    -> Type+    -- ^ The master site type+    -> Cxt+    -- ^ Context of the instance+    -> TyArgs+    -- ^ type arguments to constructors+    -> (Exp -> Q Exp)+    -- ^ Unwrap handler+    -> [ResourceTree Type]+    -- ^ The resource+    -> DecsQ+mkDispatchInstance routeOpts master cxt tyargs unwrapper res =+    -- Branch on the focus target via the accessor rather than a constructor+    -- pattern, so 'RouteOpts' can stay abstract (its constructor is not+    -- exported). 'Just target' focuses a single nested route for+    -- module-splitting; 'Nothing' generates the full top-level instance.+    case roFocusOnNestedRoute routeOpts of+        Just target ->+            mkNestedDispatchInstance routeOpts target master cxt tyargs unwrapper res+        Nothing ->+            mkTopLevelDispatchInstance routeOpts master cxt tyargs unwrapper res++mkTopLevelDispatchInstance+    :: RouteOpts+    -> Type+    -> Cxt+    -> TyArgs+    -> (Exp -> Q Exp)+    -> [ResourceTree Type]+    -> DecsQ+mkTopLevelDispatchInstance routeOpts master cxt tyargs unwrapper res = do+    let mds =+            mkMDS+                unwrapper+                [|yesodRunner|]+                [|\parentRunner getSub toParent env -> yesodSubDispatch+                    YesodSubRunnerEnv+                    { ysreParentRunner = parentRunner+                    , ysreGetSub = getSub+                    , ysreToParentRoute = toParent+                    , ysreParentEnv = env+                    }+                |]+        -- Under nested discovery this instance also emits a+        -- 'YesodDispatchNested' instance per top-level parent (see+        -- 'childNamesToGenerate'). When it does, the flat @yesodDispatch@ clause+        -- can /delegate/ each parent to that same-splice instance rather than+        -- inlining the whole subtree's dispatch logic (which the nested instance+        -- would then re-emit). Under 'InlineCompat' no nested instances are+        -- generated, so the flat clause must inline as before.+        usesNestedDiscovery =+            case discoveryMode routeOpts tyargs of+                NestedDiscovery -> True+                InlineCompat    -> False+        mdsWithNestedDispatch = mds+            { mdsNestedRouteFallthrough = roNestedRouteFallthrough routeOpts+            , mdsSameSpliceNestedInstances =+                if usesNestedDiscovery+                    then GeneratesNestedInstances+                    else NoSameSpliceNestedInstances+            }+    (childNames, clause') <- mkDispatchClause tyargs mdsWithNestedDispatch res+    let thisDispatch = FunD 'yesodDispatch [clause']+        -- Only generate 'YesodDispatchNested' instances for children when this+        -- site uses nested discovery. A parameterized site that has not opted+        -- in keeps unparameterized subroute datatypes (see 'discoveryMode' in+        -- RenderRoute), so generating nested instances — which would reference+        -- the parameterized form — must be suppressed to stay consistent.+        childNamesToGenerate =+            if usesNestedDiscovery then childNames else []+    childInstances <-+        fmap mconcat $ forM childNamesToGenerate $ \name -> do+            mkNestedDispatchInstance routeOpts name master cxt tyargs unwrapper res+    return (instanceD cxt yDispatch [thisDispatch] : childInstances)+  where+    yDispatch = ConT ''YesodDispatch `AppT` master++-- | Generate the top-level @YesodDispatchNested@ instance (and the+-- @UrlToDispatch@\/@RedirectUrl@ instances for fragments with no dynamic parent+-- pieces) for a nested route target. A thin wrapper over+-- 'mkNestedDispatchInstanceWith' with the top-level config and the master site.+--+-- @since 1.7.0.0+mkNestedDispatchInstance+    :: RouteOpts+    -> String+    -> Type+    -> Cxt+    -> TyArgs -- ^ tyargs+    -> (Exp -> Q Exp)+    -> [ResourceTree Type]+    -> Q [Dec]+mkNestedDispatchInstance routeOpts target master cxt tyargs unwrapper res =+    mkNestedDispatchInstanceWith TopLevelNested (Just master)+        routeOpts target cxt tyargs unwrapper res++-- | The shared body of the top-level ('mkNestedDispatchInstance') and subsite+-- (@mkNestedSubDispatchInstance@, in "Yesod.Core.Internal.TH") nested-dispatch+-- instance generators. Both+-- find the target, build the parent-dynamics pattern, generate the dispatch+-- clauses via 'genNestedDispatchClauses', emit one+-- 'nestedTargetClass'\/'nestedTargetFn' instance, and recurse into nested+-- children. They differ only in the 'NestedTarget' (which selects the+-- dispatch function\/class, runner, and subsite-env construction) and whether a+-- master site is in play: a @'Just' master@ marks the top-level case and additionally emits+-- the @UrlToDispatch@\/@RedirectUrl@ instances, which the subsite case+-- ('Nothing') never produces.+mkNestedDispatchInstanceWith+    :: NestedTarget+    -> Maybe Type            -- ^ @Just master@ ⇒ top-level (also emit UrlToDispatch\/RedirectUrl); @Nothing@ ⇒ subsite+    -> RouteOpts+    -> String+    -> Cxt+    -> TyArgs+    -> (Exp -> Q Exp)+    -> [ResourceTree Type]+    -> Q [Dec]+mkNestedDispatchInstanceWith nestedTarget mmaster routeOpts target cxt tyargs unwrapper res = do+    -- Resolve the target subtree from the root exactly once. The recursion into+    -- nested children below threads the already-resolved @(prePieces, subres)@+    -- straight through ('go'), rather than re-passing the full root and walking+    -- it from scratch for every descendant (which was O(nodes × depth)).+    case findNestedRoute target res of+        Nothing ->+            fail $ "Target '" ++ target ++ "' was not found in resources."+        Just (prePieces, subres) ->+            go target prePieces subres+  where+   go curTarget prePieces subres = do+    -- The parent's static depth and how many dynamic pieces it consumes (only+    -- the count matters below, for the parent-dynamics pattern and the+    -- no-dynamics UrlToDispatch case).+    let parentDepth = length prePieces+        preDyns = [() | Dynamic _ <- prePieces]+        targetT = applyTyArgs (ConT (mkName curTarget)) tyargs++    -- UrlToDispatch/RedirectUrl is a top-level-only convenience and only+    -- possible when ParentArgs ~ () (no dynamic parent pieces).+    urlToDispatchInstances <- case (mmaster, preDyns) of+        (Just master, []) ->+            mkUrlToDispatchRedirectInstances cxt curTarget targetT master+        _ ->+            pure []++    -- Generate the parent dynamic argument variables once, and derive the+    -- binding pattern from them. The clause-generator is handed the @['Name']@+    -- directly (it used to re-decode them out of the pattern).+    parentDynVars <- forM preDyns $ \_ -> newName "parentDyn"+    let parentDynsP = parentArgsPat parentDynVars++    -- Generate names for the instance parameters+    toParentN <- newName "toParentRoute"+    envN <- newName "env"+    reqN <- newName "req"++    -- Generate dispatch clauses for each child resource+    clauses <- genNestedDispatchClauses+        nestedTarget+        routeOpts+        parentDynVars+        (VarE toParentN)+        (VarE envN)+        (VarE reqN)+        unwrapper+        tyargs+        subres++    dropExp <- [| drop parentDepth (W.pathInfo $(varE reqN)) |]+    let dispatchNestedT = ConT (nestedTargetClass nestedTarget) `AppT` targetT+        thisDispatch = FunD (nestedTargetFn nestedTarget)+            [Clause+                [WildP, parentDynsP, VarP toParentN, VarP envN, VarP reqN]+                (NormalB $ CaseE dropExp clauses)+                []+            ]++    childInstances <-+        fmap mconcat $ forM subres $ \childRes -> do+            case childRes of+                ResourceParent name _ _ childPieces grandchildren -> do+                    rc <- resolveRouteCon name+                    instanceExists <- nestedInstanceExists (nestedTargetClass nestedTarget) rc+                    if instanceExists+                        then pure []+                        else do+                            -- Run the same arity guard the top-level+                            -- 'mkYesodSubDispatchInstance' applies, so a+                            -- 2nd-level-or-deeper nested datatype whose+                            -- parameter count doesn't match the (sub)site's+                            -- type arguments fails with the actionable message+                            -- rather than a cryptic kind error from generated+                            -- code. A no-op for the monomorphic (0-arity) case.+                            assertNestedSubArity+                                (nestedTargetCallSite nestedTarget)+                                (SubsiteName curTarget)+                                (SubsiteArity (tyArgsArity tyargs))+                                rc+                            -- Recurse on the already-resolved subtree: this+                            -- child's accumulated prefix is the parent's plus+                            -- this child's own pieces.+                            go name (prePieces <> childPieces) grandchildren+                _ -> pure []++    return+        ( instanceD cxt dispatchNestedT+            [ thisDispatch+            ]+        : childInstances <> urlToDispatchInstances+        )++-- | The top-level-only @UrlToDispatch@ + @RedirectUrl@ instances for a nested+-- route fragment whose @ParentArgs ~ ()@ (no dynamic parent pieces), letting+-- the fragment's constructor be used directly in @setUrl@\/@redirect@ without+-- the @WithParentArgs@ wrapper. Subsite nested dispatch emits none of these.+mkUrlToDispatchRedirectInstances+    :: Cxt+    -> String  -- ^ target route name (for the in-scope ToParentRoute check)+    -> Type    -- ^ the applied target route type+    -> Type    -- ^ the master site type+    -> Q [Dec]+mkUrlToDispatchRedirectInstances cxt target targetT master = do+    urlToDispatchT <- [t| UrlToDispatch $(pure targetT) $(pure master) |]+    urlToDispatchFn <- [e| toWaiAppYreNested (Proxy :: Proxy $(pure targetT)) () |]+    mYesodConstraint <- do+        hasYesodInstance <- isInstance ''Yesod [master]+        if hasYesodInstance+            then pure []+            else do+                yesodContext <- [t| Yesod $(pure master) |]+                pure [yesodContext]+    mToParentRouteConstraint <- do+        mtypeName <- lookupTypeName target+        parentRouteCxt <- [t| ToParentRoute $(pure targetT) |]+        case mtypeName of+            Nothing -> do+                -- must be generating it still. assume we don't+                -- have the instance in scope.+                pure [parentRouteCxt]+            Just _ -> do+                -- type is around, let's make sure it's not+                -- redundant?+                hasToParentRouteInstance <- isInstance ''ToParentRoute [targetT]+                if hasToParentRouteInstance+                    then pure []+                    else do+                        pure [parentRouteCxt]+    redirectT <- [t| RedirectUrl $(pure master) $(pure targetT) |]+    redirectUrlFn <- [e| toTextUrl . WithParentArgs () |]+    pure+        [ instanceD (cxt <> mYesodConstraint <> mToParentRouteConstraint) urlToDispatchT+            [ FunD 'urlToDispatch+                [ Clause [ WildP ] (NormalB urlToDispatchFn) []+                ]+            ]+        -- OVERLAPPABLE so a strictly more specific hand-written instance (e.g.+        -- one carrying type variables, as for a parameterized site) takes+        -- precedence over this generated convenience instance. Note that a+        -- hand-written instance with an identical fully-concrete head still+        -- collides as a duplicate, regardless of this pragma.+        , InstanceD (Just Overlappable) (cxt <> mToParentRouteConstraint) redirectT+            [ FunD 'toTextUrl+                [ Clause [ ] (NormalB redirectUrlFn) [] ]+            ]+        ]+++-- | Generate dispatch clauses for nested dispatch instances.+-- Parameterized by 'NestedTarget' to support both+-- 'YesodDispatchNested' (top-level) and 'YesodSubDispatchNested' (subsite).+genNestedDispatchClauses+    :: NestedTarget+    -> RouteOpts+    -> [Name] -- ^ parent dynamic arg variables+    -> Exp -- ^ toParentRoute expression+    -> Exp -- ^ yre expression (YesodRunnerEnv or YesodSubRunnerEnv)+    -> Exp -- ^ req expression+    -> (Exp -> Q Exp) -- ^ unwrapper+    -> TyArgs -- ^ type arguments for parameterized routes+    -> [ResourceTree Type]+    -> Q [Match]+genNestedDispatchClauses nestedTarget routeOpts parentDynVars toParentE yreE reqE unwrapper tyargs resources = do+    resourceClauses <- traverse genClauseForResource resources++    -- Terminal-miss clause: a nested dispatch instance ALWAYS returns 'Nothing'+    -- when no clause matches the remaining path, regardless of this module's+    -- fallthrough flag. 'yesodDispatchNested'/'yesodSubDispatchNested' are+    -- documented to return 'Nothing' on a miss so that the *caller* (the+    -- delegating parent clause, or the top-level/subsite terminal authority)+    -- decides whether the miss commits to a 404 or falls through to a sibling.+    -- Baking a 404 in here when fallthrough is disabled would let a split-out+    -- child silently override a fallthrough-wanting parent compiled in another+    -- module. The commit semantics of @fallthrough = False@ instead live at the+    -- delegating clauses (the 'ResourceParent' arm below and the inline parent+    -- body in 'mkDispatchClause') and at the terminal authorities.+    let fallbackClause = Match WildP (NormalB (ConE 'Nothing)) []++    return $ concat resourceClauses ++ [fallbackClause]+  where+    genClauseForResource :: ResourceTree Type -> Q [Match]+    genClauseForResource (ResourceLeaf (Resource name pieces dispatch _ _check)) = do+        (pats, dynVars) <- handlePiecesNames pieces+        let routeCon = applyConPieces name (map VarE dynVars)+            allDynVars = parentDynVars ++ dynVars++        case dispatch of+            Methods mmulti methods -> do+                -- Mirror the inline path (see 'handleDispatch' in+                -- 'mkDispatchClause'): a trailing multipiece binds a fresh+                -- @multi@ via 'EndMulti', and that value must be appended both+                -- to the route constructor's arguments and to the handler's+                -- arguments. Hardcoding 'EndExact' here would 404 any non-empty+                -- tail and build the constructor one argument short.+                (finalPat, mMultiE) <- case mmulti of+                    Nothing -> pure (EndExact, Nothing)+                    Just _ -> do+                        multiName <- newName "multi"+                        pure (EndMulti multiName, Just (VarE multiName))+                let dynExpsMulti = case mMultiE of+                        Nothing -> map VarE dynVars+                        Just e  -> map VarE dynVars ++ [e]+                    routeExp = toParentE `AppE` applyConPieces name dynExpsMulti+                    allDynExps = map VarE parentDynVars ++ dynExpsMulti+                handlerExp <- genHandlerCase name methods allDynExps+                body <-+                    [| Just ($(varE (nestedTargetRunner nestedTarget))+                                $(pure handlerExp)+                                $(pure yreE)+                                (Just $(pure routeExp))+                                $(pure reqE)) |]+                return [Match (mkPathPat finalPat pats) (NormalB body) []]++            Subsite _ getSub -> do+                restPath <- newName "restPath"+                sub2 <- mkLambda "sub" $ \sub ->+                    pure $ foldl' AppE (VarE (mkName getSub) `AppE` VarE sub) (map VarE allDynVars)+                routeLam <- mkLambda "sroute" $ \srouteN ->+                    [e| $(pure toParentE) ( $(pure routeCon) $(varE srouteN)) |]+                let reqExp' = RecUpdE reqE [('W.pathInfo, VarE restPath)]+                body <- case nestedTarget of+                    TopLevelNested ->+                        -- Top-level: construct YesodSubRunnerEnv directly+                        [| Just (yesodSubDispatch+                            YesodSubRunnerEnv+                                { ysreParentRunner = yesodRunner+                                , ysreGetSub = $(pure sub2)+                                , ysreToParentRoute = $(pure routeLam)+                                , ysreParentEnv = $(pure yreE)+                                }+                            $(pure reqExp')) |]+                    SubsiteNested ->+                        -- Subsite: compose through the outer YesodSubRunnerEnv+                        [| Just (yesodSubDispatch+                            YesodSubRunnerEnv+                                { ysreParentRunner = ysreParentRunner $(pure yreE)+                                , ysreGetSub = $(pure sub2) . ysreGetSub $(pure yreE)+                                , ysreToParentRoute = ysreToParentRoute $(pure yreE) . $(pure routeLam)+                                , ysreParentEnv = ysreParentEnv $(pure yreE)+                                }+                            $(pure reqExp')) |]+                return [Match (mkPathPat (EndRest restPath) pats) (NormalB body) []]++    genClauseForResource (ResourceParent name _check _attrs pieces _children) = do+        (pats, dynVars) <- handlePiecesNames pieces++        -- Build the parent args tuple for the nested call+        let allDynVars = parentDynVars ++ dynVars+            parentArgsExp = parentArgsExpr allDynVars+            routeConWrapper = applyConPieces name (map VarE dynVars)++        routeType <- appliedRouteTypeNamed name tyargs++        resultName <- newName "k"++        nestedCall <-+            [| $(varE (nestedTargetFn nestedTarget))+                (Proxy :: Proxy $(pure routeType))+                $(pure parentArgsExp)+                ($(pure toParentE) . $(pure routeConWrapper))+                $(pure yreE)+                $(pure reqE) |]++        if roNestedRouteFallthrough routeOpts+            then do+                -- Fallthrough enabled: pattern-guard on a 'Just' result, so a+                -- 'Nothing' from the delegated child lets dispatch fall through+                -- to sibling clauses (and ultimately the 'Nothing' fallback).+                let patGuard = BindS (conPCompat 'Just [VarP resultName]) nestedCall+                    guardedBody = GuardedB [(PatG [patGuard], ConE 'Just `AppE` VarE resultName)]+                return [Match (mkPathPat EndWild pats) guardedBody []]+            else do+                -- Fallthrough disabled: once this parent's path prefix matches we+                -- commit to its subtree. If the delegated child dispatch returns+                -- 'Nothing', convert it to a 404 handler call rather than letting+                -- the 'Nothing' propagate (which, under an outer fallthrough+                -- caller, would let it fall through to siblings). This mirrors the+                -- inline no-fallthrough path's @Nothing -> Just 404@ shape.+                committedBody <-+                    [| Just (fromMaybe+                        ($(varE (nestedTargetRunner nestedTarget))+                            (void notFound) $(pure yreE) Nothing $(pure reqE))+                        $(pure nestedCall)) |]+                return [Match (mkPathPat EndWild pats) (NormalB committedBody) []]++    genHandlerCase :: String -> [String] -> [Exp] -> Q Exp+    genHandlerCase name methods allDynExps = do+        let handlerExpFor mmethod = do+                handlerName <- defaultGetHandler mmethod name+                unwrapper $ foldl' AppE handlerName allDynExps++        if null methods+            then do+                -- No specific methods, just call handler+                handlerE <- handlerExpFor Nothing+                [| fmap toTypedContent $(pure handlerE) |]+            else do+                -- Generate method case+                -- Wrap each handler with fmap toTypedContent so all branches have the same type+                methodMatches <- forM methods $ \method -> do+                    handlerE <- handlerExpFor (Just method)+                    wrappedHandler <- [| fmap toTypedContent $(pure handlerE) |]+                    return $ Match (LitP $ StringL method) (NormalB wrappedHandler) []++                badMethodHandler <- unwrapper (VarE 'badMethod)+                let badMethodMatch = Match WildP (NormalB badMethodHandler) []+                scrutinee <- [| W.requestMethod $(pure reqE) |]+                return $ CaseE scrutinee (methodMatches ++ [badMethodMatch])++mkYesodSubDispatch :: [ResourceTree a] -> Q Exp+mkYesodSubDispatch = mkYesodSubDispatchWith defaultOpts++-- | Like 'mkYesodSubDispatch', but threads a 'RouteOpts' into the generated+-- @yesodSubDispatch@ body. The only option that affects the body is+-- 'roNestedRouteFallthrough', which controls whether a subsite's top-level+-- parent clause falls through to a later sibling on an inner miss (mirroring+-- 'mkTopLevelDispatchInstance'). 'mkYesodSubDispatch' keeps the opts-less+-- signature for backwards compatibility.+--+-- This standalone entry point never delegates a parent's dispatch to a+-- same-splice 'YesodSubDispatchNested' instance: when called on its own there+-- are no such instances being generated alongside it (delegating would emit a+-- reference to a missing instance). 'mkYesodSubDispatchInstanceOpts', which+-- /does/ generate the matching nested instances in the same splice, uses+-- 'mkYesodSubDispatchWithDelegate' to opt into delegation.+--+-- @since 1.7.0.0+mkYesodSubDispatchWith :: RouteOpts -> [ResourceTree a] -> Q Exp+mkYesodSubDispatchWith = mkYesodSubDispatchWithDelegate NoSameSpliceNestedInstances++-- | The body-generation core shared by the standalone 'mkYesodSubDispatchWith'+-- and the instance-generating 'mkYesodSubDispatchInstanceOpts'. The+-- 'SameSpliceNestedInstances' argument says whether the caller emits the+-- per-parent 'YesodSubDispatchNested' instances in the same splice — see that+-- type for what each choice means for the generated body.+--+-- @since 1.7.0.0+mkYesodSubDispatchWithDelegate+    :: SameSpliceNestedInstances -> RouteOpts -> [ResourceTree a] -> Q Exp+mkYesodSubDispatchWithDelegate sameSplice routeOpts res = do+    let mds = (mkMDS+                return+                [|subHelper|]+                [|subTopDispatch|])+                { mdsNestedTarget = SubsiteNested+                , mdsNestedRouteFallthrough = roNestedRouteFallthrough routeOpts+                , mdsSameSpliceNestedInstances = sameSplice+                }+    (_childNames, clause') <-+        mkDispatchClause+            NoTyArgs+            mds+            res+    inner <- newName "inner"+    let innerFun = FunD inner [clause']+    helper <- newName "helper"+    let fun = FunD helper+                [ Clause+                    []+                    (NormalB $ VarE inner)+                    [innerFun]+                ]+    return $ LetE [fun] (VarE helper)+++subTopDispatch ::+    (YesodSubDispatch sub master) =>+        (forall content. ToTypedContent content =>+            SubHandlerFor child master content ->+            YesodSubRunnerEnv child master ->+            Maybe (Route child) ->+            W.Application+        ) ->+        (mid -> sub) ->+        (Route sub -> Route mid) ->+        YesodSubRunnerEnv mid master ->+        W.Application+subTopDispatch _ getSub toParent env =+    yesodSubDispatch+        ( YesodSubRunnerEnv+            { ysreParentRunner = ysreParentRunner env+            , ysreGetSub = getSub . ysreGetSub env+            , ysreToParentRoute = ysreToParentRoute env . toParent+            , ysreParentEnv = ysreParentEnv env+            }+        )++mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b+mkMDS unwrapper runHandlerE subDispatcher = MkDispatchSettings+    { mdsRunHandler = runHandlerE+    , mdsSubDispatcher = subDispatcher+    , mdsGetPathInfo = [|W.pathInfo|]+    , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]+    , mdsMethod = [|W.requestMethod|]+    , mds404 = [|void notFound|]+    , mds405 = [|void badMethod|]+    , mdsGetHandler = defaultGetHandler+    , mdsUnwrapper = unwrapper+    , mdsNestedRouteFallthrough = False+    , mdsNestedTarget = TopLevelNested+    , mdsSameSpliceNestedInstances = NoSameSpliceNestedInstances+    }++-- | Parse the foundation-type string given to @mkYesod@ into its components:+-- the type-constructor name, its type arguments, and the @=>@ class-context+-- groups (each a class name applied to type arguments). Returns 'Left' with a+-- parse-error message on malformed input.+--+-- @since 1.7.0.0+parseYesodName :: String -> Either String (String, [String], [[String]])+parseYesodName name = do+    either (Left . show) Right $ parse parseName "" name+    where+        parseName = do+            cxt <- option [] parseContext+            name' <- parseWord+            args <- many parseWord+            spaces+            eof+            return ( name', args, cxt)++        parseWord = do+            spaces+            many1 alphaNum++        parseContext = try $ do+            cxts <- parseParen parseContexts+            spaces+            _ <- string "=>"+            return cxts++        parseParen p = do+            spaces+            _ <- char '('+            r <- p+            spaces+            _ <- char ')'+            return r++        parseContexts =+            sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
+ src/Yesod/Routes/TH/Internal.hs view
@@ -0,0 +1,412 @@++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}++module Yesod.Routes.TH.Internal where++import Prelude hiding (exp)+import Data.List (foldl')+import Data.Maybe (mapMaybe)+-- newName is hidden so the only one in scope is the 'Quote' class method+-- (re-exported by th-compat); with template-haskell < 2.17 the monomorphic+-- 'Language.Haskell.TH.Syntax.newName' is a distinct, ambiguous name.+import Language.Haskell.TH.Syntax hiding (newName)+import Language.Haskell.TH.Syntax.Compat (Quote(..))+import Web.PathPieces (fromPathPiece, fromPathMultiPiece)+import Yesod.Routes.TH.Types++conPCompat :: Name -> [Pat] -> Pat+conPCompat n pats = ConP n+#if MIN_VERSION_template_haskell(2,18,0)+                         []+#endif+                         pats++instanceD :: Cxt -> Type -> [Dec] -> Dec+instanceD = InstanceD Nothing++mkTupE :: [Exp] -> Exp+mkTupE =+    TupE+#if MIN_VERSION_template_haskell(2,16,0)+        . fmap Just+#endif++-- | The expression form of a route's accumulated @ParentArgs@: @()@ when there+-- are no dynamic pieces, the lone expression when there is one, and a tuple of+-- them otherwise. This is the single spelling of the unit\/single\/tuple idiom+-- that recurred across the dispatch and render-route clause builders.+parentArgsExprFromExps :: [Exp] -> Exp+parentArgsExprFromExps []  = ConE '()+parentArgsExprFromExps [e] = e+parentArgsExprFromExps es  = mkTupE es++-- | 'parentArgsExprFromExps' for the common case where the arguments are plain+-- variable names.+parentArgsExpr :: [Name] -> Exp+parentArgsExpr = parentArgsExprFromExps . map VarE++-- | The /pattern/ form of a route's accumulated @ParentArgs@, for binding the+-- incoming parent arguments: @_@ when there are none (the @ParentArgs@ is @()@+-- and ignored), the lone variable when there is one, and a tuple otherwise.+parentArgsPat :: [Name] -> Pat+parentArgsPat []  = WildP+parentArgsPat [a] = VarP a+parentArgsPat as  = TupP (map VarP as)++-- | The /type/ form of a route's accumulated @ParentArgs@: the unit type when+-- there are no dynamic pieces, the lone type when there is one, and a tuple+-- type otherwise.+parentArgsType :: [Type] -> Type+parentArgsType []  = ConT ''()+parentArgsType [t] = t+parentArgsType ts  = foldl' AppT (TupleT (length ts)) ts++-- | The number of type parameters a type constructor declares (0 for a type+-- that isn't a data\/newtype\/type-synonym, or that we can't reify).+typeArity :: Name -> Q Int+typeArity typeName = do+    info <- reify typeName+    pure $ case info of+        TyConI (DataD _ _ vs _ _ _) -> length vs+        TyConI (NewtypeD _ _ vs _ _ _) -> length vs+        TyConI (TySynD _ vs _) -> length vs+        _ -> 0++-- | Look up a type by 'Name' and return it fully applied with fresh+-- type variables. This is needed because nested route datatypes may+-- have type parameters (e.g., @NestedR subsite@), and TH functions+-- like 'isInstance' require fully-applied (kind 'Type') heads.+--+-- The application is to the datatype's /own/ reified 'typeArity', so the head+-- is saturated exactly — neither under- nor over-applied — and is therefore+-- well-kinded by construction. This holds for higher-kinded parameters too:+-- a parameter declared @(f :: Type -> Type)@ is filled with a bare,+-- unannotated @'VarT' a@, and GHC infers @a :: Type -> Type@ from the+-- datatype's declared kind, so we don't need to reconstruct each parameter's+-- kind ourselves. (Saturating by some /other/ arity — e.g. a caller's+-- 'TyArgs' count — is what historically built ill-kinded heads and made+-- 'isInstance' throw; see 'nestedInstanceExists'.)+fullyApplyType :: Name -> Q Type+fullyApplyType typeName = do+    arity <- typeArity typeName+    vars <- mapM (\i -> VarT <$> newName ("a" ++ show i)) [1..arity]+    pure $ foldl' AppT (ConT typeName) vars++-- | A route datatype name paired with the result of resolving it in the+-- current splice environment. 'rcResolved' is 'Just' when the datatype is+-- already in scope (defined in an earlier splice or a separately compiled+-- module) and 'Nothing' when it is not yet — typically because it is being+-- generated in the same splice group.+--+-- The point is to resolve a route name /once/, at the boundary, and carry the+-- answer in a value rather than re-running 'lookupTypeName' at each use site+-- and independently re-deciding what an unresolved name means. The two+-- consumers that matter — \"does its nested instance already exist?\"+-- ('nestedInstanceExists') and \"what type head do I splice?\"+-- ('appliedRouteTypeCon') — then share a single resolution.+--+-- @since 1.7.0.0+data RouteCon = RouteCon+    { rcName     :: String       -- ^ the route datatype name as written+    , rcResolved :: Maybe Name   -- ^ the resolved 'Name', if in scope+    }++-- | Resolve a route datatype name with 'lookupTypeName'. This is the single+-- boundary at which a route name is looked up; downstream code branches on the+-- resulting 'RouteCon' instead of resolving again.+--+-- @since 1.7.0.0+resolveRouteCon :: String -> Q RouteCon+resolveRouteCon name = RouteCon name <$> lookupTypeName name++-- | Does an instance of the given (nested-discovery) class — e.g.+-- @''YesodDispatchNested@, @''RenderRouteNested@, @''ParseRouteNested@,+-- @''RouteAttrsNested@ — already exist for this route datatype? This is the+-- single delegation probe shared by all the generators: when it answers 'True'+-- the parent delegates to the existing instance, and when 'False' it inlines+-- (or generates) the child itself.+--+-- Two rules, applied uniformly so the probe can never abort a splice:+--+--   * An unresolved 'RouteCon' (the datatype is being generated in the same+--     splice) trivially has no instance yet, so the answer is 'False'.+--   * A resolved one is saturated by its /own/ reified arity via+--     'fullyApplyType' — never by the site's 'TyArgs'. Applying the site's+--     type args to a child that was generated at a different arity (e.g. a+--     kind-'Type' child of a parameterized site) builds an ill-kinded head,+--     and 'isInstance' /throws/ a kind error rather than returning 'False',+--     aborting the splice. Saturating by the datatype's own arity keeps the+--     probed head well-kinded in every case.+--+-- /Can the abstract parameters make 'isInstance' fail?/ No. Once the head is+-- well-kinded (above), 'isInstance' answers by head unification — \"could+-- /any/ visible instance match this head?\" — which is a total query: it+-- returns 'True' or 'False' but cannot crash on an abstract @'VarT' a@. The+-- one theoretical imprecision is /over-matching/: because the argument is an+-- unconstrained variable, an instance written only at a more specific type+-- (e.g. @instance C (R Int)@) would still unify with @C (R a)@ and report+-- 'True'. That is harmless here because our codegen emits the nested-discovery+-- instances uniformly, one per route datatype at a fully abstract parameter+-- (e.g. @instance YesodDispatchNested (R a)@), so \"could match\" and \"does+-- match\" coincide — there is no narrower instance for the probe to confuse a+-- variable with. (Higher-kinded parameters are covered by the same argument;+-- see 'fullyApplyType'.)+--+-- @since 1.7.0.0+nestedInstanceExists :: Name -> RouteCon -> Q Bool+nestedInstanceExists klass rc =+    case rcResolved rc of+        Nothing       -> pure False+        Just typeName -> do+            appliedT <- fullyApplyType typeName+            isInstance klass [appliedT]++-- | The fully-applied route 'Type' for a 'RouteCon', as used for an instance+-- head. This is the single place the \"saturate by site 'TyArgs' vs. by the+-- datatype's own reified arity\" choice is made:+--+--   * With explicit 'TyArgs' (a parameterized site) the supplied type+--     arguments are applied to the constructor — the resolved 'Name' if in+--     scope, otherwise the bare 'mkName' (so a datatype being generated in the+--     same splice still gets a head to reference).+--   * With 'NoTyArgs' a resolved datatype is reified and saturated with fresh+--     type variables (needed for e.g. @mkYesodSubDispatch@, which doesn't know+--     the parent's type args); an unresolved one falls back to the bare+--     constructor.+--+-- @since 1.7.0.0+appliedRouteTypeCon :: RouteCon -> TyArgs -> Q Type+appliedRouteTypeCon rc tyargs =+    case (rcResolved rc, tyargs) of+        (Just typeName, NoTyArgs)     -> fullyApplyType typeName+        (Just typeName, SomeTyArgs{}) -> pure $ applyTyArgs (ConT typeName) tyargs+        (Nothing,       _)            -> pure $ applyTyArgs (ConT (mkName (rcName rc))) tyargs++-- | 'appliedRouteTypeCon' starting from the route datatype's name as a+-- 'String': resolve it ('resolveRouteCon') and apply the type arguments. The+-- fallback for an unresolved name (the bare constructor) is why this can't be+-- a plain @'lookupTypeName' >>=@ that requires the name to be in scope.+appliedRouteTypeNamed :: String -> TyArgs -> Q Type+appliedRouteTypeNamed routeName tyargs = do+    rc <- resolveRouteCon routeName+    appliedRouteTypeCon rc tyargs++-- | A subsite's type-constructor name. Distinct from 'RouteName' so the two+-- can't be swapped at a 'checkNestedSubArity' call site without a type error.+--+-- @since 1.7.0.0+newtype SubsiteName = SubsiteName String deriving (Eq, Show)++-- | A nested route datatype's name. See 'SubsiteName'.+--+-- @since 1.7.0.0+newtype RouteName = RouteName String deriving (Eq, Show)++-- | How many type arguments a subsite has. Distinct from 'RouteArity' so the+-- two arities can't be swapped (the equality predicate is symmetric, but the+-- error message is not).+--+-- @since 1.7.0.0+newtype SubsiteArity = SubsiteArity Int deriving (Eq, Show)++-- | The declared type-parameter arity of a nested route datatype. See+-- 'SubsiteArity'.+--+-- @since 1.7.0.0+newtype RouteArity = RouteArity Int deriving (Eq, Show)++-- | A detected mismatch between a subsite's type-argument count and its nested+-- route datatype's declared arity. Carrying the four facts (rather than a+-- pre-rendered 'String') lets the caller decide how to surface it and lets+-- tests assert on structure instead of substring-matching a message.+--+-- @since 1.7.0.0+data ArityMismatch = ArityMismatch+    { amSubsiteName  :: SubsiteName+    , amRouteName    :: RouteName+    , amSubsiteArity :: SubsiteArity+    , amRouteArity   :: RouteArity+    } deriving (Eq, Show)++-- | Validate that a parameterized subsite's nested route datatype carries+-- exactly as many type parameters as the subsite has type arguments: 'Nothing'+-- when the arities match, or a structured 'ArityMismatch' otherwise.+--+-- 'mkYesodSubDispatchInstance' applies the subsite's type arguments to each+-- nested route datatype (e.g. @NestedR subsite@) and uses the result directly+-- as the head of a @YesodSubDispatchNested@ instance, which expects a fully+-- applied (kind 'Type') route. So the arities must match exactly:+--+--   * Too few parameters on the nested datatype (e.g. it was generated by+--     plain 'mkYesodSubData', kind 'Type') over-applies it.+--   * Too many leaves it partially applied (kind @Type -> ...@).+--+-- Either way the result is a kind error reported deep inside generated code.+-- Surfacing it here (the caller passes the 'ArityMismatch' to 'fail') turns+-- it into an actionable, attributable message.+--+-- Pure so it can be unit-tested directly.+--+-- @since 1.7.0.0+checkNestedSubArity+    :: SubsiteName+    -> RouteName+    -> SubsiteArity+    -> RouteArity+    -> Maybe ArityMismatch+checkNestedSubArity subName routeName (SubsiteArity subArgs) (RouteArity nestedArity)+    | subArgs == nestedArity = Nothing+    | otherwise = Just $ ArityMismatch subName routeName (SubsiteArity subArgs) (RouteArity nestedArity)++-- | Which generator is running the arity check. The arity facts are identical+-- either way; this only steers 'arityMismatchMessage' so the failure names the+-- right entry point and calls the parameterized thing by its correct term+-- (a top-level site reached through the nested-dispatch recursion is not a+-- \"subsite\").+--+-- @since 1.7.0.0+data ArityCallSite+    = SubsiteCall   -- ^ a subsite, generated by 'mkYesodSubDispatchInstance'+    | TopLevelCall  -- ^ a top-level site's nested-dispatch recursion+    deriving (Eq, Show)++-- | Run 'checkNestedSubArity' for a (possibly unresolved) nested route+-- datatype and 'fail' with 'arityMismatchMessage' on a mismatch. A no-op when+-- the datatype is not in scope — an unresolved name has no knowable arity, so+-- the error (if any) surfaces from the generated code instead. This is the+-- single arity-guard shared by 'mkYesodSubDispatchInstance' and the nested+-- dispatch-instance recursion.+--+-- @since 1.7.0.0+assertNestedSubArity :: ArityCallSite -> SubsiteName -> SubsiteArity -> RouteCon -> Q ()+assertNestedSubArity callSite subName subArity rc =+    case rcResolved rc of+        Nothing -> pure ()+        Just tyname -> do+            nestedArity <- typeArity tyname+            maybe (pure ()) (fail . arityMismatchMessage callSite) $+                checkNestedSubArity subName (RouteName (rcName rc)) subArity (RouteArity nestedArity)++-- | The actionable @fail@ message for an 'ArityMismatch', phrased for the+-- 'ArityCallSite' that detected it.+--+-- @since 1.7.0.0+arityMismatchMessage :: ArityCallSite -> ArityMismatch -> String+arityMismatchMessage callSite (ArityMismatch (SubsiteName subName) (RouteName routeName) (SubsiteArity subArgs) (RouteArity nestedArity)) =+    concat+        [ prefix, ": the nested route datatype `", routeName+        , "` has ", show nestedArity, " type parameter(s), but the ", term, " `"+        , subName, "` has ", show subArgs+        , ". The subroute datatypes must carry exactly the ", term, "'s type "+        , "parameter(s) — generate the ", term, "'s routes with "+        , "`mkYesodSubDataOpts (setParameterizedSubroute True defaultOpts) ...` "+        , "so a parameterized ", term, " gets parameterized subroutes."+        ]+  where+    (prefix, term) = case callSite of+        SubsiteCall  -> ("mkYesodSubDispatchInstance", "subsite")+        TopLevelCall -> ("mkYesod", "site")++-- | Turn a single route piece into a match pattern, returning the freshly+-- bound 'Name' for dynamic pieces (and 'Nothing' for static ones). The+-- fresh-'Name' supply is the 'Quote' @m@ it runs in: the 'Q' code generators+-- run at 'Q' (hygienic 'newName'), while the pure, deterministic inline-parse+-- path runs at a 'Quote' instance over a monotonic counter (see the test+-- harness). This is the single source of truth for the+-- @ViewP fromPathPiece (Just x)@ dynamic encoding shared by the parse and+-- dispatch clause builders.+handlePieceM :: Quote m => Piece a -> m (Pat, Maybe Name)+handlePieceM (Static str) = pure (LitP $ StringL str, Nothing)+handlePieceM (Dynamic _) = mk <$> newName "dyn"+  where+    mk x = (ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x]), Just x)++-- | The list form of 'handlePieceM' projecting the dynamic binders as 'Name's,+-- for callers that consume the bound variables directly (e.g. nested-dispatch+-- handler arguments).+handlePiecesNames :: Quote m => [Piece a] -> m ([Pat], [Name])+handlePiecesNames =+    fmap (\pps -> (map fst pps, mapMaybe snd pps)) . traverse handlePieceM++-- | The list form of 'handlePieceM' projecting the dynamic binders as 'VarE'+-- expressions, for callers that rebuild a route by applying its constructor to+-- the captured pieces.+handlePiecesM :: Quote m => [Piece a] -> m ([Pat], [Exp])+handlePiecesM =+    fmap (\(pats, names) -> (pats, map VarE names)) . handlePiecesNames++-- | Rebuild a route by applying its constructor (named by 'String', resolved+-- with 'mkName') to the captured dynamic-piece expressions — the companion to+-- 'handlePiecesM', which produces the @['Exp']@. This is the single spelling+-- of the @'foldl'' 'AppE' ('ConE' ('mkName' name))@ route-construction idiom+-- that recurred across the dispatch and parse clause builders.+applyConPieces :: String -> [Exp] -> Exp+applyConPieces name = foldl' AppE (ConE (mkName name))++-- | @composeE f g@ is the expression @f . g@.+composeE :: Exp -> Exp -> Exp+composeE f g = InfixE (Just f) (VarE '(.)) (Just g)++-- | @consE x xs@ is the expression @x : xs@.+consE :: Exp -> Exp -> Exp+consE x xs = InfixE (Just x) (ConE '(:)) (Just xs)++-- | How a path match pattern ends, after its matched piece patterns. Only+-- these four shapes are ever valid as a path tail, so making it a closed type+-- (rather than an arbitrary 'Pat') stops a caller from silently matching the+-- wrong number of segments — e.g. binding a @rest@ where the path was meant to+-- end exactly.+data PathTail+    = EndExact      -- ^ @[]@ — the path ends exactly here+    | EndRest Name  -- ^ bind the remaining segments to the given variable+    | EndWild       -- ^ @_@ — ignore any remaining segments+    | EndMulti Name -- ^ a trailing multipiece: @'fromPathMultiPiece' -> 'Just' n@++-- | The 'Pat' a 'PathTail' denotes (the seed the matched piece patterns are+-- consed onto in 'mkPathPat').+pathTailPat :: PathTail -> Pat+pathTailPat EndExact     = conPCompat '[] []+pathTailPat (EndRest n)  = VarP n+pathTailPat EndWild      = WildP+pathTailPat (EndMulti n) = ViewP (VarE 'fromPathMultiPiece) (conPCompat 'Just [VarP n])++-- | Build a path match pattern: a list pattern of the given piece patterns+-- ending in the given 'PathTail'.+mkPathPat :: PathTail -> [Pat] -> Pat+mkPathPat tl = foldr (\x y -> conPCompat '(:) [x, y]) (pathTailPat tl)++-- | Generate a single-argument lambda expression with a fresh name.+-- Takes a base name hint, generates a unique 'Name', and passes it+-- to a callback that produces the lambda body. Returns the complete+-- 'LamE' expression.+--+-- For multi-argument lambdas, nest calls — @\\x y -> body@ is+-- equivalent to @\\x -> \\y -> body@.+mkLambda :: String -> (Name -> Q Exp) -> Q Exp+mkLambda hint mkBody = do+    n <- newName hint+    bdy <- mkBody n+    pure $ LamE [VarP n] bdy++-- | Given a target 'String', find the 'ResourceParent' in the+-- @['ResourceTree' a]@ corresponding to that target and return it.+-- Also return the @['Piece' a]@ captures that precede it.+findNestedRoute :: String -> [ResourceTree a] -> Maybe ([Piece a], [ResourceTree a])+findNestedRoute _ [] = Nothing+findNestedRoute target (res : ress) =+    case res of+        ResourceLeaf _ ->+            findNestedRoute target ress+        ResourceParent name _overlap _attrs pieces children -> do+            if name == target+                then Just (pieces, children)+                else+                    let mresult = findNestedRoute target children+                    in+                        case mresult of+                            Nothing -> do+                                findNestedRoute target ress+                            Just (typs, childRoute) -> do+                                Just (pieces <> typs, childRoute)
+ src/Yesod/Routes/TH/ParseRoute.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++module Yesod.Routes.TH.ParseRoute+    ( -- ** ParseRoute+      mkParseRouteInstance+    , mkParseRouteInstanceOpts+    , mkParseRouteInstanceFor+      -- ** Clause construction (monad-polymorphic over 'Quote'; testable purely)+    , buildInlineParseClauses+    , generateParseRouteClause+    ) where++import qualified Control.Monad.Trans as Trans+import qualified Data.Set as Set+import Control.Monad+import Yesod.Routes.TH.Types+import Language.Haskell.TH (varE, varP)+import Language.Haskell.TH.Syntax hiding (newName)+import Language.Haskell.TH.Syntax.Compat (Quote(..), unsafeQToQuote)+import Yesod.Routes.Class+import Yesod.Routes.TH.RenderRoute+import Control.Monad.State.Strict+import Yesod.Routes.TH.Internal++-- | The trailing @_ -> Nothing@ clause appended to every generated+-- @parseRoute@\/@parseRouteNested@: a path matching none of the preceding+-- clauses fails to parse.+missingRouteClause :: Clause+missingRouteClause = Clause [WildP] (NormalB (ConE 'Nothing)) []++mkParseRouteInstance :: TyArgs -> Cxt -> Type -> [ResourceTree a] -> Q [Dec]+mkParseRouteInstance =+    mkParseRouteInstanceOpts defaultOpts++-- | Generate a ParseRouteNested instance for a specific nested route target.+-- This is a convenience wrapper around mkParseRouteInstanceOpts with setFocusOnNestedRoute.+--+-- @since 1.7.0.0+mkParseRouteInstanceFor :: String -> [ResourceTree a] -> Q [Dec]+mkParseRouteInstanceFor target ress = do+    let opts = setFocusOnNestedRoute target defaultOpts+        targetType = ConT (mkName target)+    mkParseRouteInstanceOpts opts NoTyArgs [] targetType ress++-- | Generate the 'ParseRoute' instance (and, under nested discovery, the+-- accompanying 'ParseRouteNested' instances) for a site, honoring the supplied+-- 'RouteOpts' and the site's 'TyArgs'. The options-driven core that+-- 'mkParseRouteInstanceFor' and the @mkYesod@ entry points build on.+--+-- @since 1.7.0.0+mkParseRouteInstanceOpts :: RouteOpts -> TyArgs -> Cxt -> Type -> [ResourceTree a] -> Q [Dec]+mkParseRouteInstanceOpts routeOpts origTyargs cxt typ unfocusedRess =+    case discoveryMode routeOpts origTyargs of+        -- Backwards-compatible default: generate a single 'ParseRoute'+        -- instance with all nested routes inlined, and no 'ParseRouteNested'+        -- instances.+        InlineCompat -> do+            clausess <- mapM (buildInlineParseClauses id) unfocusedRess+            let allClauses = concat clausess <> [missingRouteClause]+            pure+                [ instanceD cxt (ConT ''ParseRoute `AppT` typ)+                    [ FunD 'parseRoute allClauses+                    ]+                ]+        NestedDiscovery -> do+            ress <- focusTarget unfocusedRess+            existingInstances <- existingNestedInstances ress+            (clauses, childNames) <- flip runStateT mempty $ traverse (generateParseRouteClause existingInstances routeOpts) ress++            childInstances <- fmap join $ forM (Set.toList childNames) $ \childName ->+                mkParseRouteInstanceOpts routeOpts { roFocusOnNestedRoute = Just childName } origTyargs cxt (targetTypeFor childName) ress++            let allClauses = clauses <> [missingRouteClause]++            let thisInstance =+                    case roFocusOnNestedRoute routeOpts of+                        Just target ->+                            instanceD cxt (ConT ''ParseRouteNested `AppT` targetTypeFor target)+                                [ FunD 'parseRouteNested allClauses+                                ]+                        Nothing ->+                            instanceD cxt (ConT ''ParseRoute `AppT` typ)+                                [ FunD 'parseRoute allClauses+                                ]++            pure $ thisInstance : childInstances+  where+    -- The route datatype named by @name@, applied to the site's type arguments.+    targetTypeFor name = applyTyArgs (ConT (mkName name)) origTyargs++    -- Narrow to the focused subtree's children via the shared lookup, failing+    -- loudly (matching Dispatch/RenderRoute) when the target is missing rather+    -- than silently producing an always-'Nothing' 'ParseRouteNested' instance.+    focusTarget ts =+        case roFocusOnNestedRoute routeOpts of+            Just target ->+                case findNestedRoute target ts of+                    Nothing ->+                        fail $ "Target '" ++ target ++ "' was not found in resources."+                    Just (_prePieces, children) ->+                        pure children+            Nothing ->+                pure ts++-- | Probe (in 'Q') which of the given resources' top-level parents already+-- have a 'ParseRouteNested' instance. Pulling these compiler queries+-- ('isInstance', via 'nestedInstanceExists') out of 'generateParseRouteClause'+-- is what lets that generator be monad-polymorphic over 'Quote' — and thus+-- runnable, and testable, at a pure 'Quote' instance.+--+-- @since 1.7.0.0+existingNestedInstances :: [ResourceTree a] -> Q (Set.Set String)+existingNestedInstances ress = do+    flags <- mapM check ress+    pure $ Set.fromList (concat flags)+  where+    check (ResourceParent name _ _ _ _) = do+        rc <- resolveRouteCon name+        has <- nestedInstanceExists ''ParseRouteNested rc+        pure [name | has]+    check ResourceLeaf{} = pure []++-- | Generate a single @parseRouteNested@-delegating clause for one resource+-- (under nested discovery). It records, into its 'StateT' accumulator, the+-- name of each parent that still needs a 'ParseRouteNested' instance generated.+--+-- The \"does this name already have an instance?\" decision is a compiler query+-- ('isInstance'), which would pin this to 'Q'; it is instead /hoisted out/ and+-- passed in as @existingInstances@, leaving only fresh-name generation as an+-- effect. That makes the generator monad-polymorphic over 'Quote': it runs at+-- 'Q' in production and at a pure 'Quote' instance (a monotonic counter) in+-- tests.+--+-- @since 1.7.0.0+generateParseRouteClause+    :: Quote m+    => Set.Set String+    -- ^ Route names that already have a 'ParseRouteNested' instance (so this+    -- clause should not re-request one). Computed by the caller in 'Q' via+    -- 'nestedInstanceExists'; pass 'mempty' in pure tests.+    -> RouteOpts+    -> ResourceTree a+    -> StateT (Set.Set String) m Clause+generateParseRouteClause existingInstances routeOpts resourceTree =+    case resourceTree of+        ResourceLeaf (Resource name pieces dispatch _ _check) -> do+            (pats, dyns) <- liftQ $ handlePiecesM pieces++            case dispatch of+                Methods multi _ -> do+                    (finalTail, dyns') <-+                        case multi of+                            Nothing ->+                                pure (EndExact, dyns)+                            Just _ -> do+                                multiName <- liftQ $ newName "multi"+                                pure (EndMulti multiName, dyns ++ [VarE multiName])++                    queryParamsName <- liftQ $ newName "_queryParams"+                    let route = applyConPieces name dyns'+                        jroute = ConE 'Just `AppE` route+                        pathPat = mkPathPat finalTail pats+                        pat = TupP [pathPat, VarP queryParamsName]+                    pure $ Clause [pat] (NormalB jroute) []++                Subsite _ _ -> do+                    restName <- liftQ $ newName "rest"+                    queryParamsName <- liftQ $ newName "_queryParams"++                    let route = applyConPieces name dyns+                        pathPat = mkPathPat (EndRest restName) pats+                        pat = TupP [pathPat, VarP queryParamsName]+                        tupExp = mkTupE [VarE restName, VarE queryParamsName]+                        expr = VarE 'fmap+                            `AppE` route+                            `AppE` (VarE 'parseRoute `AppE` tupExp)+                    pure $ Clause [pat] (NormalB expr) []++        ResourceParent name _check _attrs pieces _children -> do+            recordNameIfNotInstance name++            (pats, dyns) <- liftQ $ handlePiecesM pieces++            let route = applyConPieces name dyns++            restName <- liftQ $ newName "rest"+            queryParamsName <- liftQ $ newName "_queryParams"++            let parseRouteOnRest =+                    VarE 'parseRouteNested+                        `AppE` mkTupE [VarE restName, VarE queryParamsName]++            body <-+                    if roNestedRouteFallthrough routeOpts+                        then do+                            resultName <- liftQ $ newName "result"+                            let stmt = BindS (AsP resultName (conPCompat 'Just [WildP])) parseRouteOnRest+                                expr = VarE 'fmap `AppE` route `AppE` VarE resultName+                            pure $ GuardedB [(PatG [stmt], expr)]+                        else+                            pure $ NormalB (VarE 'fmap `AppE` route `AppE` parseRouteOnRest)++            let pat = TupP [mkPathPat (EndRest restName) pats, VarP queryParamsName]+            pure $ Clause [pat] body []++  where+    liftQ :: Monad n => n a -> StateT (Set.Set String) n a+    liftQ = Trans.lift++    -- Record that @name@ still needs a 'ParseRouteNested' instance generated.+    -- The instance-existence decision is hoisted out (into @existingInstances@,+    -- computed in 'Q' by the caller), so this stays pure.+    recordNameIfNotInstance name =+        unless (name `Set.member` existingInstances) $+            modify (Set.insert name)++-- | Backwards-compatible inline @parseRoute@ clause generation. It assembles+-- the @parseRoute@ clauses for the inline path directly as AST, drawing fresh+-- names from a 'Quote' name supply and building tuples\/applications by hand+-- rather than through quotation brackets+-- (brackets are monomorphic 'Q' before template-haskell 2.17; the one+-- exception goes through 'unsafeQToQuote').+--+-- Each call yields one clause per resource tree: a leaf is its own matching+-- clause, while a parent is a single clause that matches its path prefix and+-- then cases the remaining @(path, queryParams)@ over its children (their+-- clauses turned into match alternatives) ending in a @_ -> 'Nothing'@+-- fallback. That fallback is the commit-on-parent-prefix behaviour: once the+-- parent prefix matches, a child miss is a definite 'Nothing' rather than a+-- fall-through to a sibling top-level route.+--+-- It is monad-polymorphic in the name supply via 'Quote': production runs it at+-- 'Q' (so binders are hygienic 'newName's), while tests run it at a pure+-- 'Quote' instance backed by a monotonic counter, where names are deterministic+-- and the '[Clause]' output can be asserted on directly without splicing or+-- 'runQ'. Under the deterministic supply every name is a freshly-bound pattern+-- variable scoped to its clause, the shared counter keeps them distinct within a+-- tree, and it is threaded through the parent\/child recursion so a parent+-- binder never collides with a child's.+--+-- @since 1.7.0.0+buildInlineParseClauses+    :: Quote m+    => (Exp -> Exp)+    -- ^ Wrap a child-route expression in the accumulated parent constructors.+    -> ResourceTree a+    -> m [Clause]+buildInlineParseClauses wrap resourceTree =+    map matchToClause <$> buildInlineParseMatches wrap resourceTree+  where+    -- Each parse match is a single @(path, queryParams)@ pattern with a body,+    -- which is exactly a top-level @parseRoute@ clause. Total by construction —+    -- 'Match' and 'Clause' carry the same body\/@where@ shape — so no partial+    -- destructure is needed.+    matchToClause :: Match -> Clause+    matchToClause (Match pat body decs) = Clause [pat] body decs++-- | The matching alternatives behind 'buildInlineParseClauses', one per+-- resource tree. Producing 'Match'es (rather than 'Clause's) is what lets a+-- parent splice its children straight into a @case@: a leaf is one+-- @(path, queryParams)@ alternative, and a parent is one alternative that+-- matches its path prefix then cases the remaining @(path, queryParams)@ over+-- its children's alternatives, ending in a @_ -> 'Nothing'@ fallback. At top+-- level 'buildInlineParseClauses' turns each alternative back into its own+-- @parseRoute@ clause.+buildInlineParseMatches+    :: Quote m+    => (Exp -> Exp)+    -- ^ Wrap a child-route expression in the accumulated parent constructors.+    -> ResourceTree a+    -> m [Match]+buildInlineParseMatches wrap resourceTree =+    case resourceTree of+        ResourceLeaf (Resource name pieces dispatch _ _check) -> do+            (pats, dyns) <- handlePiecesM pieces+            case dispatch of+                Methods multi _ -> do+                    (finalTail, dyns') <-+                        case multi of+                            Nothing ->+                                pure (EndExact, dyns)+                            Just _ -> do+                                multiName <- newName "multi"+                                pure (EndMulti multiName, dyns ++ [VarE multiName])+                    queryParamsName <- newName "_queryParams"+                    let route = applyConPieces name dyns'+                        jroute = ConE 'Just `AppE` wrap route+                        pathPat = mkPathPat finalTail pats+                        pat = TupP [pathPat, VarP queryParamsName]+                    pure [Match pat (NormalB jroute) []]++                Subsite _ _ -> do+                    restName <- newName "rest"+                    queryParamsName <- newName "_queryParams"+                    subName <- newName "sub"+                    let route = applyConPieces name dyns+                        wrapSub = wrap (route `AppE` VarE subName)+                        pathPat = mkPathPat (EndRest restName) pats+                        pat = TupP [pathPat, VarP queryParamsName]+                    -- 'unsafeQToQuote' because brackets are monomorphic 'Q'+                    -- on template-haskell < 2.17. It is safe here: the only+                    -- effect a bracket performs is drawing hygiene names for+                    -- its binders, and this one has none (the lambda binder+                    -- comes from a splice).+                    expr <- unsafeQToQuote [e|+                        fmap+                            (\ $(varP subName) -> $(pure wrapSub) )+                            (parseRoute ( $(varE restName), $(varE queryParamsName) ) )+                        |]+                    pure [Match pat (NormalB expr) []]++        ResourceParent name _check _attrs pieces children -> do+            (pats, dyns) <- handlePiecesM pieces+            restName <- newName "rest"+            queryParamsName <- newName "_queryParams"+            let parentCon childRoute =+                    applyConPieces name dyns `AppE` childRoute+                wrap' = wrap . parentCon++            -- Build each child's matching alternative relative to the remaining+            -- @(rest, queryParams)@ scope, then fold them into a single @case@+            -- that commits at this parent: a child miss falls to the+            -- @_ -> Nothing@ alternative instead of escaping to a sibling+            -- top-level route.+            childMatches <- concat <$> mapM (buildInlineParseMatches wrap') children+            let restTup = mkTupE [VarE restName, VarE queryParamsName]+                fallbackMatch = Match WildP (NormalB (ConE 'Nothing)) []+                caseExpr = CaseE restTup (childMatches ++ [fallbackMatch])+                pathPat = mkPathPat (EndRest restName) pats+                pat = TupP [pathPat, VarP queryParamsName]+            pure [Match pat (NormalB caseExpr) []]
+ src/Yesod/Routes/TH/RenderRoute.hs view
@@ -0,0 +1,979 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+-- 'TemplateHaskellQuotes' is not enough here: on GHC < 9.0 it does not+-- enable nested @$(...)@ splices inside brackets (they parse as the @$@+-- operator and trigger cross-stage 'Lift' errors).+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++module Yesod.Routes.TH.RenderRoute+    ( -- ** RenderRoute+      mkRenderRouteInstanceOpts+    , mkRouteConsOpts+    , shouldCreateResources++    , RouteOpts+    , defaultOpts+    , setEqDerived+    , setShowDerived+    , setReadDerived+    , setCreateResources+    , setFocusOnNestedRoute+    , unsetFocusOnNestedRoute+    , roFocusOnNestedRoute+    , roNestedRouteFallthrough+    , setParameterizedSubroute+    , setNestedRouteFallthrough+    , DiscoveryMode(..)+    , discoveryMode+    ) where++import Data.Maybe+import Yesod.Routes.TH.Types+import Language.Haskell.TH (varE, varP)+import Language.Haskell.TH.Syntax+import Control.Monad+import Data.Text (pack)+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))+import Yesod.Routes.Class+import Data.Foldable+import Yesod.Routes.TH.Internal+import Data.Char+import Yesod.Core.Class.Dispatch.ToParentRoute++-- | General opts data type for generating yesod.+--+-- Contains options for customizing code generation for the router in+-- 'mkYesodData', including what type class instances will be derived for+-- the route datatype, whether to parameterize subroutes,+-- and whether or not to create the @resources :: [ResourceTree String]@ value.+-- Use the setting functions on `defaultOpts` to set specific fields.+--+-- @since 1.6.25.0+data RouteOpts = MkRouteOpts+    { roDerivedEq   :: Bool+    , roDerivedShow :: Bool+    , roDerivedRead :: Bool+    , roCreateResources :: Bool+    , roFocusOnNestedRoute :: Maybe String+    -- ^ If this option is set, then we will only generate datatypes for+    -- the nested subroute that matches this string.+    --+    -- @since 1.7.0.0+    , roParameterizedSubroute :: Bool+    , roNestedRouteFallthrough :: Bool+    -- ^ If 'True', then a nested route will fall through if it fails to+    -- match. If 'False', then a nested route will throw 'notFound' if it+    -- does not match.+    --+    -- Default: 'False'.+    --+    -- @since 1.7.0.0+    }++-- | Default options for generating routes.+--+-- The defaults are:+--+--   * 'setEqDerived', 'setShowDerived', 'setReadDerived': 'True' — derive+--     'Eq', 'Show' and 'Read' for the route datatype.+--   * 'setCreateResources': 'True' — emit the @resourcesSite ::+--     [ResourceTree String]@ term.+--   * 'setParameterizedSubroute': 'False' — subroutes are unparameterized.+--   * 'setFocusOnNestedRoute': unset — generate the whole route tree+--     rather than focusing on a single nested route.+--   * 'setNestedRouteFallthrough': 'False' — a nested route that fails to+--     match throws 'notFound' instead of falling through.+--+-- Use the @set*@ functions to override individual fields.+--+-- @since 1.6.25.0+defaultOpts :: RouteOpts+defaultOpts = MkRouteOpts+    { roDerivedEq = True+    , roDerivedShow = True+    , roDerivedRead = True+    , roCreateResources = True+    , roParameterizedSubroute = False+    , roFocusOnNestedRoute = Nothing+    , roNestedRouteFallthrough = False+    }++-- | If you set this with @routeName@, then the code generation will+-- generate code for the @routeName@ to be imported in the main dispatch+-- class. This allows you to generate code in separate modules.+--+-- Example:+--+-- First, you would put your route definitions into their own file.+--+-- @+-- module App.Routes.Resources where+--+-- import Yesod.Core+--+-- appResources :: [ResourceTree String]+-- appResources = [parseRoutes|+--     /  HomeR GET+--+--     /nest NestR:+--         /     NestIndexR GET POST+--         /#Int NestShowR  GET POST+--+-- |]+-- @+--+-- We have defined a nested route called @NestR@ here. A nested route is+-- created with the @:@ after the route name.+--+-- Then, in a module for the route specifically, we can generate the route+-- datatype and instances for later hooking in to the main instance.+--+-- @+-- module App.Routes.NestR where+--+-- import App.Routes.Resources+-- import Yesod.Core+--+-- mkYesodOpts (setFocusOnNestedRoute "NestR" defaultOpts) "App" appResources+-- @+--+-- If you only want to generate the datatypes, you can separate things+-- further using 'mkYesodDataOpts' and 'mkYesodDispatchOpts'.+--+-- Finally, import that type into your main yesod macro code.+--+-- @+-- module App where+--+-- import App.Routes.Resources (appResources)+-- import App.Routes.NestR (NestR(..))+--+-- mkYesod "App" appResources+-- @+--+-- The call to 'mkYesod' will delegate to the generated code for @NestR@+-- rather than regenerating it.+--+-- By default, 'defaultOpts' starts unfocused (the whole route tree is+-- generated). Use 'unsetFocusOnNestedRoute' to clear a previously-set focus.+--+-- For a full walkthrough — including subsites, linking to nested routes, and+-- why split sites should enable 'setNestedRouteFallthrough' — see the guide at+-- <https://github.com/yesodweb/yesod/blob/master/yesod-core/docs/split-route-compilation.md>.+--+-- @since 1.7.0.0+setFocusOnNestedRoute :: String -> RouteOpts -> RouteOpts+setFocusOnNestedRoute str rdo = rdo { roFocusOnNestedRoute = Just str }++-- | Clear any nested-route focus set by 'setFocusOnNestedRoute', so that+-- the whole route tree is generated.+--+-- 'defaultOpts' already starts unfocused, so this is only needed to undo a+-- previous 'setFocusOnNestedRoute'.+--+-- @since 1.7.0.0+unsetFocusOnNestedRoute :: RouteOpts -> RouteOpts+unsetFocusOnNestedRoute rdo = rdo { roFocusOnNestedRoute = Nothing }++-- | When 'True', a nested route that fails to match falls through to the+-- enclosing dispatch rather than throwing 'notFound'. When 'False', a+-- non-matching nested route throws 'notFound'.+--+-- Default: 'False'.+--+-- @since 1.7.0.0+setNestedRouteFallthrough :: Bool -> RouteOpts -> RouteOpts+setNestedRouteFallthrough b rdo = rdo { roNestedRouteFallthrough = b }++-- | When 'True', derive an 'Eq' instance for the route datatype.+--+-- Default: 'True'.+--+-- @since 1.6.25.0+setEqDerived :: Bool -> RouteOpts -> RouteOpts+setEqDerived b rdo = rdo { roDerivedEq = b }++-- | When 'True', derive a 'Show' instance for the route datatype.+--+-- Default: 'True'.+--+-- @since 1.6.25.0+setShowDerived :: Bool -> RouteOpts -> RouteOpts+setShowDerived b rdo = rdo { roDerivedShow = b }++-- | When 'True', derive a 'Read' instance for the route datatype.+--+-- Default: 'True'.+--+-- @since 1.6.25.0+setReadDerived :: Bool -> RouteOpts -> RouteOpts+setReadDerived b rdo = rdo { roDerivedRead = b }++-- | Determine whether or not to generate the @resourcesApp@ value.+--+-- Disabling this can be useful if you are creating the @routes ::+-- [ResourceTree String]@ elsewhere in your module, and referring to it+-- here. The @resourcesApp@ can become very large in large applications,+-- and duplicating it can result in signifiacntly higher compile times.+--+-- Default: 'True'.+--+-- @since 1.6.28.0+setCreateResources :: Bool -> RouteOpts -> RouteOpts+setCreateResources b rdo = rdo { roCreateResources = b }++-- | Returns whether or not we should create the @resourcesSite ::+-- [ResourceTree String]@ value during code generation.+--+-- @since 1.6.28.0+shouldCreateResources :: RouteOpts -> Bool+shouldCreateResources = roCreateResources++-- | If True, generate nested-discovery code (separate subroute datatypes and+-- @RenderRouteNested@ / dispatch instances) for a /parameterized/ site instead+-- of the backwards-compatible inline output. The subroute datatypes then carry+-- the parent site's type variables so that the @ParentSite@ \/ @ParentArgs@+-- associated types stay well-scoped.+--+-- Because the generated nested instances are parameterized over the site's+-- type variables, the splice emits instance heads with non-variable arguments;+-- a module using this typically needs @FlexibleContexts@, @FlexibleInstances@,+-- @MultiParamTypeClasses@, @TypeFamilies@ and, for a parameterized subsite+-- whose @master@ is determined by the @subsite@ (a @subsite -> master@+-- functional dependency on the user's class), @UndecidableInstances@.+--+-- Monomorphic sites always use nested discovery regardless of this flag; see+-- 'discoveryMode'.+--+-- Default: 'False'.+--+-- @since 1.6.28.0+setParameterizedSubroute :: Bool -> RouteOpts -> RouteOpts+setParameterizedSubroute b rdo = rdo { roParameterizedSubroute = b }++-- |+--+-- @since 1.6.25.0+instanceNamesFromOpts :: RouteOpts -> [Name]+instanceNamesFromOpts MkRouteOpts {..} = prependIf roDerivedEq ''Eq $ prependIf roDerivedShow ''Show $ prependIf roDerivedRead ''Read []+    where prependIf b = if b then (:) else const id++-- | How a route datatype's children are generated.+--+-- @since 1.7.0.0+data DiscoveryMode+    = -- | The backwards-compatible default for a /parameterized/ site that has+      -- not opted in: subroute datatypes stay unparameterized (kind 'Type')+      -- and @renderRoute@ \/ @parseRoute@ \/ dispatch inline the children,+      -- exactly as pre-nested-discovery Yesod did. Generating the discovery+      -- machinery here would put the parent's type variables out of scope on+      -- the child datatype, so we don't.+      InlineCompat+    | -- | Generate the "nested route discovery" machinery: parameterized+      -- subroute datatypes plus the @RenderRouteNested@ \/ @ParseRouteNested@+      -- \/ @YesodDispatchNested@ \/ @ToParentRoute@ \/ @UrlToDispatch@ \/+      -- @RedirectUrl@ instances and the delegating method bodies that go with+      -- them.+      NestedDiscovery+    deriving (Eq, Show)++-- | Classify how a route datatype's children should be generated, given the+-- site's route options and its 'TyArgs'.+--+-- 'NestedDiscovery' is chosen when any of the following hold:+--+--   * The site has /no/ type parameters ('hasTyArgs' is 'False', e.g. a+--     monomorphic site like @App@). Subroute datatypes then need no type+--     variables, so the machinery is always safe, and this preserves the+--     historical behaviour of monomorphic sites (including splitting nested+--     routes across modules).+--+--   * Parameterized subroutes were explicitly requested+--     ('setParameterizedSubroute'). The subroute datatypes then carry the+--     parent's type variables so the @ParentSite@ \/ @ParentArgs@ associated+--     types are well-scoped.+--+--   * We are focusing on a nested route for module-splitting+--     ('setFocusOnNestedRoute').+--+-- @since 1.7.0.0+discoveryMode :: RouteOpts -> TyArgs -> DiscoveryMode+discoveryMode opts tyargs+    | not (hasTyArgs tyargs)             = NestedDiscovery+    | roParameterizedSubroute opts       = NestedDiscovery+    | isJust (roFocusOnNestedRoute opts) = NestedDiscovery+    | otherwise                          = InlineCompat++-- | 'PlainTV' across template-haskell versions. @th-abstraction@ covers this,+-- but the version it was introduced in isn't always available — and the+-- 'TyVarBndr' /flag/ type also varies by version, so the result type is+-- CPP-guarded too. Used to build the type-variable binders of generated+-- subroute datatypes.+plainTVCompat :: Name ->+#if MIN_VERSION_template_haskell(2,21,0)+    TyVarBndr BndrVis+#elif MIN_VERSION_template_haskell(2,17,0)+    TyVarBndr ()+#else+    TyVarBndr+#endif+plainTVCompat =+#if MIN_VERSION_template_haskell(2,21,0)+    (`PlainTV` BndrReq)+#elif MIN_VERSION_template_haskell(2,17,0)+    (`PlainTV` ())+#else+    PlainTV+#endif++-- | Build the data constructor for a route leaf: @LeafR ty… [multi] [Route Sub]@.+-- Shared by the full-tree ('mkRouteConsOpts') and focused-nested+-- ('mkRenderRouteNestedInstanceOpts') constructor generators, which previously+-- spelled this identically.+leafRouteCon :: Resource Type -> Con+leafRouteCon res =+    NormalC (mkName $ resourceName res)+        $ map (notStrict,)+        $ concat [singles, multi, sub]+  where+    singles = concatMap toSingle $ resourcePieces res+    toSingle Static{}      = []+    toSingle (Dynamic typ) = [typ]+    multi = maybeToList $ resourceMulti res+    sub =+        case resourceDispatch res of+            Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]+            _ -> []++-- | Build the data constructor for a route parent: @ParentR ty… (ChildR tyargs…)@,+-- whose trailing field is the (possibly type-argument-applied) child route+-- datatype. Shared by the full-tree and focused-nested constructor generators.+parentRouteCon :: String -> [Piece Type] -> TyArgs -> Con+parentRouteCon name pieces tyargs =+    NormalC (mkName name)+        $ map (notStrict,)+        $ singles ++ [applyTyArgs (ConT (mkName name)) tyargs]+  where+    singles = concatMap toSingle pieces+    toSingle Static{}      = []+    toSingle (Dynamic typ) = [typ]++-- | The deriving context for a child\/subroute datatype. The site's instance+-- context only makes sense on a child that actually carries the type+-- arguments; an unparameterized child (the backwards-compatible default)+-- can't, so deriving with that context would leave the variables ambiguous.+-- Nullify the context in that case, mirroring historical Yesod.+childDerivCxt :: TyArgs -> Cxt -> Cxt+childDerivCxt tyargs cxt+    | hasTyArgs tyargs = cxt+    | otherwise        = []++-- | Generate the constructors of a route data type, with custom+-- 'RouteOpts'.+--+-- The first element in the return is the list of constructors for the+-- @Route site@ datatype. The second element is the list of 'Dec' to+-- declare nested datatypes or class instances of the 'RenderRouteNested'+-- for those instances.+--+-- @since 1.6.25.0+mkRouteConsOpts :: RouteOpts -> Cxt -> TyArgs -> Type -> [ResourceTree Type] -> Q ([Con], [Dec])+mkRouteConsOpts opts cxt origTyargs master resourceTrees = do+    (prePieces, focusedTrees) <-+        case roFocusOnNestedRoute opts of+            Nothing ->+                pure ([], resourceTrees)+            Just target -> do+                let mnestedRoute = findNestedRoute target resourceTrees+                case mnestedRoute of+                    Nothing ->+                        fail $ "Target '" <> target <> "' was not found in resources."+                    Just r ->+                        pure r+    mkRouteConsOpts' prePieces focusedTrees+  where+    -- When nested route discovery is enabled, child datatypes carry the+    -- parent's type variables, because RenderRouteNested has associated type+    -- families (ParentSite, ParentArgs) that reference the parent type;+    -- without the type variables on the child datatype, they'd be out of+    -- scope on the RHS of the type family instance.+    --+    -- When it is disabled (the backwards-compatible default), child+    -- datatypes are unparameterized (kind 'Type'), matching the historical+    -- output. See 'discoveryMode'. Computed once and reused below.+    mode = discoveryMode opts origTyargs+    tyargs =+        case mode of+            NestedDiscovery -> origTyargs+            InlineCompat    -> NoTyArgs+    subrouteDecTypeArgs = fmap plainTVCompat (tyArgsBinders tyargs)++    -- Derives for the child (subroute) datatypes. See 'childDerivCxt'.+    childCxt = childDerivCxt tyargs cxt+    (inlineDerives, mkStandaloneDerives) = getDerivesFor opts childCxt++    mkRouteConsOpts' :: [Piece Type] -> [ResourceTree Type] -> Q ([Con], [Dec])+    mkRouteConsOpts' prePieces trees = do+        results <- mapM (mkRouteCon prePieces) trees+        pure (mconcat results)++    mkRouteCon :: [Piece Type] -> ResourceTree Type -> Q ([Con], [Dec])+    mkRouteCon _ (ResourceLeaf res) =+        -- A leaf is always a constructor of the (possibly focused) datatype:+        -- in focus mode we have already narrowed @resourceTrees@ to the+        -- target's children, so every leaf reached here is a leaf of the+        -- focused route.+        pure ([leafRouteCon res], [])++    mkRouteCon prePieces (ResourceParent name _check _attrs pieces children) = do+        -- Accumulate pieces for children: combine parent pieces with this route's pieces+        let accumulatedPieces = prePieces <> pieces+        (cons, decs) <- mkRouteConsOpts' accumulatedPieces children+        let childDataName = mkName name++        -- Generate the child datatype if it has not been generated+        -- already, but only if we are *not* focusing on some other+        -- datatype.+        mname' <- lookupTypeName name+        mdec <- case mname' of+            Just _ -> do+                -- datatype already exists, definitely don't generate it+                pure Nothing+            Nothing -> do+                let childData = mkChildDataGen childDataName cons inlineDerives+                    childDataType = applyTyArgs (ConT childDataName) tyargs+                case roFocusOnNestedRoute opts of+                    Just target | target /= name ->+                        -- If we have a target, and this ain't it, don't+                        -- generate+                        pure Nothing+                    _ | InlineCompat <- mode ->+                        -- Backwards-compatible default: emit just the+                        -- (unparameterized) child datatype and its standalone+                        -- derives. No RenderRouteNested instance; renderRoute+                        -- inlines the children.+                        pure $ Just (childData : mkStandaloneDerives childDataType)+                    _ ->+                        -- Nested discovery: either `Just target | target ==+                        -- name` (matching a target, and this is it) or+                        -- `Nothing` (no target, or we already found it). Emit+                        -- the child datatype plus its RenderRouteNested+                        -- instance so the parent's renderRoute can delegate.+                        Just <$>+                            nestedChildDataAndInstance+                                opts cxt childCxt tyargs master childDataName cons+                                (prePieces <> pieces) children++        return ([parentRouteCon name pieces tyargs], maybe id (<>) mdec decs)+      where+        mkChildDataGen :: Name -> [Con] -> [DerivClause] -> Dec+        mkChildDataGen childDataName cons conts =+            DataD [] childDataName subrouteDecTypeArgs Nothing cons conts++-- | The shared preamble for rendering a 'ResourceParent': fresh names for the+-- parent's dynamic pieces and for the wrapped @child@ route, plus the+-- constructor pattern @Name dyn… child@ binding them. Returns the dynamic+-- names, the child name, and the pattern.+parentConPat :: String -> [Piece a] -> Q ([Name], Name, Pat)+parentConPat name pieces = do+    let cnt = length [() | Dynamic{} <- pieces]+    dyns <- replicateM cnt $ newName "dyn"+    child <- newName "child"+    pure (dyns, child, conPCompat (mkName name) $ map VarP $ dyns ++ [child])++-- | Is this path piece a dynamic capture, as opposed to a static segment?+isDynamic :: Piece t -> Bool+isDynamic Dynamic{} = True+isDynamic _ = False++-- | Render a route's path pieces to a list of @Text@-valued expressions,+-- pairing each 'Dynamic' piece with its bound variable in order. Fails the+-- splice if the piece list and the binder list are out of sync (a dynamic+-- piece with no corresponding bound variable).+mkPieces :: (String -> Exp) -> Exp -> [Piece t] -> [Name] -> Q [Exp]+mkPieces _ _ [] _ = pure []+mkPieces toText tsp (Static s:ps) dyns = (toText s :) <$> mkPieces toText tsp ps dyns+mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = (tsp `AppE` VarE d :) <$> mkPieces toText tsp ps dyns+mkPieces _ _ (Dynamic _ : _) [] =+    fail "RenderRoute.mkPieces: a dynamic path piece has no corresponding bound variable (route definition and piece-binder list are out of sync)"++-- | Clauses for the 'renderRoute' method. This should be called from the+-- instance derivation for 'RenderRoute'.+mkRenderRouteClauses :: RouteOpts -> TyArgs -> [ResourceTree Type] -> Q [Clause]+mkRenderRouteClauses opts origTyargs =+    goList+  where+    goList = fmap mconcat . mapM go++    mode = discoveryMode opts origTyargs++    go (ResourceParent name _check _attrs pieces children) =+        case mode of+            -- Opted in to nested discovery: the parent's renderRoute delegates+            -- to the child's RenderRouteNested instance.+            NestedDiscovery -> goNested+            -- Backwards-compatible default: inline the child clauses,+            -- prepending this parent's path pieces, exactly as historical+            -- Yesod did.+            InlineCompat -> goInline+      where+        goNested = do+            (dyns, child, pat) <- parentConPat name pieces++            body <- [| renderRouteNested $(pure (parentArgsExpr dyns)) $(pure (VarE child)) |]+            pure [Clause [pat] (NormalB body) []]++        goInline = do+            (dyns, child, pat) <- parentConPat name pieces++            pack' <- [|pack|]+            tsp <- [|toPathPiece|]+            piecesSingle <- mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns++            childRender <- newName "childRender"+            childClauses <- goList children++            body <- delegatingBody piecesSingle (VarE childRender) (VarE child)++            pure [Clause [pat] (NormalB body) [FunD childRender childClauses]]++    go (ResourceLeaf res) = do+        let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)+        dyns <- replicateM cnt $ newName "dyn"+        sub <-+            case resourceDispatch res of+                Subsite{} -> return <$> newName "sub"+                _ -> return []+        let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub++        pack' <- [|pack|]+        tsp <- [|toPathPiece|]+        piecesSingle <- mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns++        piecesMulti <-+            case resourceMulti res of+                Nothing -> return $ ListE []+                Just{} -> do+                    tmp <- [|toPathMultiPiece|]+                    return $ tmp `AppE` VarE (last dyns)++        body <-+            case sub of+                [x] -> do+                    rr <- [|renderRoute|]+                    delegatingBody piecesSingle rr (VarE x)+                _ ->+                    return $ mkTupE [foldr consE piecesMulti piecesSingle, ListE []]++        return [Clause [pat] (NormalB body) []]++-- | Build a renderRoute body that delegates its tail to another render+-- function — either a nested child's @renderRouteNested@ (the inline+-- 'ResourceParent' arm) or an embedded subsite's @renderRoute@ (the+-- 'ResourceLeaf' subsite arm). The path-piece list passed in is prepended to+-- the delegate's path list (callers include any parent pieces themselves) and+-- the query string is threaded through unchanged.+delegatingBody+    :: [Exp]    -- ^ this route's own path pieces (already including any parent pieces)+    -> Exp      -- ^ the delegate render function+    -> Exp      -- ^ the child/subsite route argument to render+    -> Q Exp+delegatingBody piecesSingle rr childArg = do+    a <- newName "a"+    b <- newName "b"+    let pieces' = foldr consE (VarE a) piecesSingle+    [e| ( \ ( $(varP a), $(varP b) ) -> ( $(pure pieces'), $(varE b) ) )+        ( $(pure rr) $(pure childArg) )+        |]++-- | Like 'mkRenderRouteClauses', but instead generates clauses for the+-- definition of 'renderRouteNested'.+--+-- @since 1.7.0.0+mkRenderRouteNestedClauses+    :: [Either String Name]+    -- ^ Either the static path piece or the names of the tuple of the parent arg.+    --+    -- These are both necessary to re-synthesize the total route.+    -> [ResourceTree Type]+    -> Q [Clause]+mkRenderRouteNestedClauses parentArgsNames resources = do+    fmap mconcat . mapM go $ resources+  where+    go (ResourceParent name _check _attrs pieces _children) = do+        (dyns, child, pat) <- parentConPat name pieces++        -- Extract parent dynamic variables from parentArgsNames+        let parentDyns = mapMaybe (either (const Nothing) Just) parentArgsNames++        -- Accumulate parent args: combine parent dynamic vars with this route's dynamic vars+        let allDyns = parentDyns ++ dyns+            accumulatedParentArgsExp = parentArgsExpr allDyns++        -- The body should call renderRouteNested with accumulated parent args+        body <- [| renderRouteNested $(pure accumulatedParentArgsExp) $(pure (VarE child)) |]+        pure [Clause [parentArgsPat parentDyns, pat] (NormalB body) []]++    go (ResourceLeaf res) = do+        let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)+        dyns <- replicateM cnt $ newName "dyn"+        sub <-+            case resourceDispatch res of+                Subsite{} -> return <$> newName "sub"+                _ -> return []+        let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub++        pack' <- [|pack|]+        tsp <- [|toPathPiece|]++        -- Build the FULL path including parent pieces+        -- parentArgsNames contains Either String Name for each piece in the parent path+        let parentDyns = mapMaybe (either (const Nothing) Just) parentArgsNames++        -- Build parent path pieces from parentArgsNames+        parentPieces <- mkParentPieces pack' tsp parentArgsNames parentDyns+        -- Build this resource's own pieces+        thisResourcePieces <- mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns++        piecesMulti <-+            case resourceMulti res of+                Nothing -> return $ ListE []+                Just{} -> do+                    tmp <- [|toPathMultiPiece|]+                    return $ tmp `AppE` VarE (last dyns)++        body <-+            case sub of+                [x] -> do+                    rr <- [|renderRoute|]+                    -- Combine parent pieces with this resource's pieces+                    delegatingBody (parentPieces ++ thisResourcePieces) rr (VarE x)+                _ -> do+                    colon <- [|(:)|]+                    let cons a b = InfixE (Just a) colon (Just b)+                    -- Combine parent pieces with this resource's pieces+                    let allPieces = parentPieces ++ thisResourcePieces+                    return $ mkTupE [foldr cons piecesMulti allPieces, ListE []]++        return [Clause [parentArgsPat parentDyns, pat] (NormalB body) []]++    -- Build path pieces from parentArgsNames (which contains both static and dynamic pieces)+    mkParentPieces :: Exp -> Exp -> [Either String Name] -> [Name] -> Q [Exp]+    mkParentPieces pack' tsp parentArgsNames' parentDyns = goParentPieces parentArgsNames' parentDyns+      where+        goParentPieces [] _ = pure []+        goParentPieces (Left staticStr : rest) dyns =+            ((pack' `AppE` LitE (StringL staticStr)) :) <$> goParentPieces rest dyns+        goParentPieces (Right _ : rest) (dyn : dyns) =+            ((tsp `AppE` VarE dyn) :) <$> goParentPieces rest dyns+        goParentPieces (Right _ : _) [] =+            fail "RenderRoute.mkParentPieces: a dynamic parent path piece has no corresponding bound variable"++-- | The shared core of every 'RenderRouteNested' instance body. From a parent+-- route's accumulated path pieces and its child resources it computes the+-- @ParentArgs@ tuple 'Type' and the @renderRouteNested@ method clauses. The+-- three instance-emitting sites (the inline child datatype in+-- 'mkRenderRouteInstanceOpts', the focused target in+-- 'mkRenderRouteNestedInstanceOpts', and that target's nested children) differ+-- only in the instance head, the @ParentSite@ right-hand side, and the context+-- they wrap around this — so only those wrappers remain at the call sites, and+-- the piece-naming\/clause-building boilerplate (including the dynamic-binder+-- name derivation) lives here once.+renderRouteNestedBody+    :: [Piece Type]            -- ^ accumulated parent path pieces+    -> [ResourceTree Type]     -- ^ child resources+    -> Q (Type, [Clause])      -- ^ (ParentArgs tuple type, renderRouteNested clauses)+renderRouteNestedBody prepieces children = do+    let piecesAndNames =+            map (\p -> case p of+                    Static str -> Left str+                    Dynamic a -> Right a)+                prepieces+        preDyns = mapMaybe (either (const Nothing) Just) piecesAndNames+    let parentDynT = parentArgsType preDyns+    parentNames <- forM piecesAndNames $ \epiece'name ->+        case epiece'name of+            Left piece -> pure (Left piece)+            Right t ->+                case filter isAlphaNum (show t) of+                    (a : as) -> Right <$> newName (toLower a : as)+                    []       -> fail+                        "renderRouteNested: a dynamic piece's type renders with no alphanumeric characters, so no binder name can be derived from it"+    childClauses <- mkRenderRouteNestedClauses parentNames children+    pure (parentDynT, childClauses)++-- | Generate the 'RenderRoute' instance.+--+-- This includes both the 'Route' associated type and the+-- 'renderRoute' method.  This function uses both 'mkRouteConsOpts' and+-- 'mkRenderRouteClauses'.+--+-- @since 1.6.25.0+mkRenderRouteInstanceOpts+    :: RouteOpts+    -> Cxt+    -- ^ The context passed around for the instances+    -> TyArgs+    -- ^ Type arguments+    -> Type+    -- ^ The type of the foundation resource+    -> [ResourceTree Type]+    -- ^ The actual tree of routes to generate code for+    -> Q [Dec]+mkRenderRouteInstanceOpts opts cxt tyargs typ ress = do+    case roFocusOnNestedRoute opts of+        Nothing -> do+            cls <- mkRenderRouteClauses opts tyargs ress+            (cons, decs) <- mkRouteConsOpts opts cxt tyargs typ ress+            let did = DataInstD []+#if MIN_VERSION_template_haskell(2,15,0)+                    Nothing routeDataName+#else+                    ''Route [typ]+#endif+                    Nothing cons inlineDerives+            -- ToParentRoute instances are only needed by the nested-discovery+            -- machinery; the backwards-compatible default emits none.+            parentRouteInstancesDecs <-+                case discoveryMode opts tyargs of+                    NestedDiscovery -> mkToParentRouteInstances cxt tyargs ress+                    InlineCompat    -> pure []+            pure $ mconcat+                [ pure $ instanceD cxt (ConT ''RenderRoute `AppT` typ)+                    [ did+                    , FunD 'renderRoute cls+                    ]+                , mkStandaloneDerives routeDataName+                , decs+                , parentRouteInstancesDecs+                ]+        Just target ->+            case findNestedRoute target ress of+                Nothing ->+                    fail $ "Target '" <> target <> "' was not found in resources."+                Just (prepieces, ress') ->+                    mkRenderRouteNestedInstanceOpts opts cxt tyargs typ prepieces target ress'+  where+    routeDataName = ConT ''Route `AppT` typ+    (inlineDerives, mkStandaloneDerives) = getDerivesFor opts cxt++-- | Get the simple derivation clauses and the standalone derivation clauses+-- for a given type and context.+--+-- If there are any additional classes needed for context, we just produce standalone+-- clauses. Else, we produce basic deriving clauses for a declaration.+getDerivesFor :: RouteOpts -> Cxt -> ([DerivClause], Type ->  [Dec])+getDerivesFor opts cxt+    | null cxt =+        ( [DerivClause Nothing clazzes']+        , const []+        )+    | otherwise =+        ( []+        , \typ -> fmap (StandaloneDerivD Nothing cxt . (`AppT` typ)) clazzes'+        )+  where+    clazzes' = ConT <$> instanceNamesFromOpts opts++-- | For each datatype, generate an instance of 'ToParentRoute' for the+-- datatype. Instances should mostly look like this:+--+-- > instance ToParentRoute FooR where+-- >     toParentRoute (a0, a1) = FooR a0 a1+mkToParentRouteInstances :: Cxt -> TyArgs -> [ResourceTree Type] -> Q [Dec]+mkToParentRouteInstances cxt origTyargs ress = do+    mconcat <$> mapM (go ([], [])) ress+  where+    go _ (ResourceLeaf _) =+        pure []+    go (accPieces, parentConstructors) (ResourceParent name _check _attrs pieces children) = do+        -- Extract dynamic types from accumulated parent pieces+        let accDynTypes = [t | Dynamic t <- accPieces]+        accDynVars <- mapM (\_ -> newName "parent") accDynTypes++        -- Extract dynamic types from this route's pieces+        let piecesDynTypes = [t | Dynamic t <- pieces]+        piecesDynVars <- mapM (\_ -> newName "piece") piecesDynTypes++        -- Child route variable+        child <- newName "child"++        -- ParentArgs includes BOTH acc and pieces dynamic vars+        let allParentDynVars = accDynVars ++ piecesDynVars++        -- Build the full route by applying all parent constructors+        -- We need to partition allParentDynVars according to each constructor's piece count+        let applyConToParentArgs = buildRouteExpr parentConstructors (mkName name) allParentDynVars (VarE child)++        let toParentRouteD =+                FunD 'toParentRoute+                    [ Clause+                        [parentArgsPat allParentDynVars, VarP child]+                        (NormalB applyConToParentArgs)+                        []+                    ]++        let thisInstance =+                instanceD cxt (ConT ''ToParentRoute `AppT` applyTypeVariables name) [toParentRouteD]++        -- Accumulate pieces and constructor info for children+        let thisPieceCount = length piecesDynTypes+            acc' =+                ( accPieces <> pieces+                , parentConstructors ++ [(mkName name, thisPieceCount)]+                )++        childrenInstances <- mconcat <$> mapM (go acc') children+        pure $ thisInstance : childrenInstances++    applyTypeVariables name =+        applyTyArgs (ConT (mkName name)) origTyargs++    -- Build the route expression by applying constructors from outermost to innermost+    buildRouteExpr :: [(Name, Int)] -> Name -> [Name] -> Exp -> Exp+    buildRouteExpr parentCtors thisCtor allDynVars childExpr =+        let -- All constructors including this one+            thisPieceCount = length allDynVars - sum (map snd parentCtors)+            allCtors = parentCtors ++ [(thisCtor, thisPieceCount)]++            -- Partition dynamic vars for each constructor+            partitionedVars = go' allDynVars allCtors+              where+                go' _ [] = []+                go' vars ((_, count) : rest) =+                    let (varsForThis, remaining) = splitAt count vars+                    in varsForThis : go' remaining rest++            -- Build expression from inside out using foldr+            finalExpr = foldr+                (\(ctorName, varsForThis) innerExpr ->+                    foldl' AppE (ConE ctorName) (map VarE varsForThis ++ [innerExpr]))+                childExpr+                (zip (map fst allCtors) partitionedVars)+        in finalExpr++notStrict :: Bang+notStrict = Bang NoSourceUnpackedness NoSourceStrictness++-- | Assemble a @RenderRouteNested@ instance from the pieces that vary between+-- the three sites that emit one (the inline child datatype in+-- 'mkRouteConsOpts', the focused target and its nested children in+-- 'mkRenderRouteNestedInstanceOpts'). The context, child route 'Type',+-- @ParentSite@ right-hand side (the foundation 'Type') and @ParentArgs@ tuple+-- 'Type' plus the @renderRouteNested@ clauses are all that differ; everything+-- else is shared here.+--+-- @since 1.7.0.0+mkRenderRouteNestedInstanceD+    :: Cxt        -- ^ instance context+    -> Type       -- ^ the child route datatype (instance head argument)+    -> Type       -- ^ the @ParentSite@ right-hand side (the foundation type)+    -> Type       -- ^ the @ParentArgs@ tuple type+    -> [Clause]   -- ^ the @renderRouteNested@ method clauses+    -> Dec+mkRenderRouteNestedInstanceD instCxt childRouteType parentSiteRHS parentArgsT clauses =+    instanceD+        instCxt+        (ConT ''RenderRouteNested `AppT` childRouteType)+        [ TySynInstD $ TySynEqn Nothing (ConT ''ParentSite `AppT` childRouteType) parentSiteRHS+        , TySynInstD $ TySynEqn Nothing (ConT ''ParentArgs `AppT` childRouteType) parentArgsT+        , FunD 'renderRouteNested clauses+        ]++-- | Generate the declarations for a nested-discovery /child/ datatype: the+-- (parameterized) datatype declaration, its @RenderRouteNested@ instance, and+-- any standalone deriving clauses. Shared by every nested-discovery+-- constructor generator ('mkRouteConsOpts' and 'mkRenderRouteNestedInstanceOpts')+-- so the datatype shape, instance context, and @ParentSite@\/@ParentArgs@ wiring+-- stay in one place. The focus\/inline gating that decides /whether/ to emit+-- these stays at the call sites, since that differs between them.+--+-- @since 1.7.0.0+nestedChildDataAndInstance+    :: RouteOpts+    -> Cxt           -- ^ instance context for the @RenderRouteNested@ instance+    -> Cxt           -- ^ deriving context for the child datatype (nullified when+                     --   the child carries no type arguments; see 'mkRouteConsOpts')+    -> TyArgs        -- ^ type arguments carried by the child datatype+    -> Type          -- ^ the @ParentSite@ right-hand side (the foundation type)+    -> Name          -- ^ the child datatype name+    -> [Con]         -- ^ the child datatype's constructors+    -> [Piece Type]  -- ^ accumulated parent path pieces for this child+    -> [ResourceTree Type] -- ^ the child's own children+    -> Q [Dec]+nestedChildDataAndInstance opts instCxt derivCxt tyargs parentSiteRHS childDataName cons accPieces children = do+    let subrouteDecTypeArgs = fmap plainTVCompat (tyArgsBinders tyargs)+        (inlineDerives, mkStandaloneDerives) = getDerivesFor opts derivCxt+        childData = DataD [] childDataName subrouteDecTypeArgs Nothing cons inlineDerives+        childDataType = applyTyArgs (ConT childDataName) tyargs+    (parentDynT, childClauses) <- renderRouteNestedBody accPieces children+    let childInstance =+            mkRenderRouteNestedInstanceD instCxt childDataType parentSiteRHS parentDynT childClauses+    pure (childData : childInstance : mkStandaloneDerives childDataType)++mkRenderRouteNestedInstanceOpts+    :: RouteOpts+    -> Cxt+    -> TyArgs+    -> Type+    -> [Piece Type]+    -> String+    -> [ResourceTree Type]+    -> Q [Dec]+mkRenderRouteNestedInstanceOpts routeOpts cxt tyargs typ prepieces target ress = do+    -- Generate constructors for all children+    (cons, childDecs) <- mkFocusedChildCons prepieces ress++    let targetName = mkName target+        targetDecs =+            -- The focused target datatype and its RenderRouteNested instance+            -- are emitted through the same shared builder as the in-module+            -- and nested-child paths, so the instance context is plain @cxt@+            -- (matching the in-module generator); demanding extra+            -- Eq/Show/Read constraints on the site type arguments here would+            -- be undischargeable at the delegating RenderRoute instance.+            nestedChildDataAndInstance+                routeOpts cxt childCxt tyargs typ targetName cons prepieces ress++    -- Return the datatype declaration, instance, and any standalone derives,+    -- followed by the declarations for any nested children.+    (<> childDecs) <$> targetDecs+  where+    -- The focused datatype carries the site's type arguments. See 'childDerivCxt'.+    childCxt = childDerivCxt tyargs cxt++    -- Generate constructors and nested-instance declarations for the children+    -- of the focused target. Structurally similar to 'mkRouteConsOpts'' inner+    -- @mkRouteCon@, but deliberately NOT shared: there we are walking the whole+    -- site and must honour the focus gate (skip datatypes other than the+    -- target) and the InlineCompat branch. Here every tree is already *inside*+    -- the focused target, so each parent unconditionally gets its+    -- RenderRouteNested instance — applying the focus gate here would wrongly+    -- skip grandchild instances.+    mkFocusedChildCons :: [Piece Type] -> [ResourceTree Type] -> Q ([Con], [Dec])+    mkFocusedChildCons prePieces trees =+        mconcat <$> mapM (mkFocusedChildCon prePieces) trees++    mkFocusedChildCon :: [Piece Type] -> ResourceTree Type -> Q ([Con], [Dec])+    mkFocusedChildCon _ (ResourceLeaf res) =+        pure ([leafRouteCon res], [])++    mkFocusedChildCon prePieces (ResourceParent name _check _attrs pieces children) = do+        let accumulatedPieces = prePieces <> pieces+        (cons, decs) <- mkFocusedChildCons accumulatedPieces children+        let childDataName = mkName name++        -- Generate the child datatype and its RenderRouteNested instance unless+        -- the datatype already exists (generated by another split-out module).+        mname' <- lookupTypeName name+        mdec <- case mname' of+            Just _ -> pure Nothing+            Nothing ->+                Just <$>+                    nestedChildDataAndInstance+                        routeOpts cxt childCxt tyargs typ childDataName cons+                        accumulatedPieces children++        return ([parentRouteCon name pieces tyargs], maybe id (<>) mdec decs)
+ src/Yesod/Routes/TH/RouteAttrs.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Yesod.Routes.TH.RouteAttrs+    ( mkRouteAttrsInstance+    , mkRouteAttrsInstanceFor+    , mkRouteAttrsNestedInstances+    ) where++import Yesod.Routes.TH.Types+import Yesod.Routes.TH.Internal (nestedInstanceExists, resolveRouteCon, instanceD, conPCompat, findNestedRoute)+import Yesod.Routes.Class+import Language.Haskell.TH.Syntax+import Data.Foldable (toList)+import qualified Data.Set  as Set+import qualified Data.Text as Text+import Control.Monad++mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec+mkRouteAttrsInstance cxt typ ress = do+    clauses <- mapM (goTree Nothing id) ress+    return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)+        [ FunD 'routeAttrs $ concat clauses +++                [Clause [ WildP ] (NormalB $ VarE 'mempty) []]+        ]++-- | Like 'mkRouteAttrsInstance', but uses a 'String' name of a nested+-- subroute to generate nested instances instead of generating the full+-- instance for all routes.+--+-- @since 1.7.0.0+mkRouteAttrsInstanceFor :: Cxt -> Type -> String -> [ResourceTree a] -> Q [Dec]+mkRouteAttrsInstanceFor cxt typ target ress = do+    -- Fail loudly (matching Dispatch/RenderRoute/ParseRoute) when the focus+    -- target is missing, rather than silently emitting an always-'mempty'+    -- 'RouteAttrsNested' instance.+    case findNestedRoute target ress of+        Nothing ->+            fail $ "Target '" ++ target ++ "' was not found in resources."+        Just _ ->+            pure ()+    clauses <- mapM (goTree (Just target) id) ress+    return [instanceD cxt (ConT ''RouteAttrsNested `AppT` typ)+        [ FunD 'routeAttrsNested $ concat clauses +++                [Clause [ WildP ] (NormalB $ VarE 'mempty) []]+        ]+        ]++-- | Generate a 'RouteAttrsNested' instance for every nested parent route in+-- the tree (recursively), skipping any whose instance already exists (e.g. one+-- generated in another module when routes are split). This is the+-- 'RouteAttrs' counterpart to the @RenderRouteNested@ \/ @ParseRouteNested@ \/+-- @YesodDispatchNested@ instances that a plain 'mkYesod' already emits for its+-- child route fragments, so that @routeAttrsNested ChildR@ resolves for a+-- single-module site just like the other nested-delegation methods do.+--+-- @since 1.7.0.0+mkRouteAttrsNestedInstances :: Cxt -> TyArgs -> [ResourceTree a] -> Q [Dec]+mkRouteAttrsNestedInstances cxt tyargs ress =+    concat <$> mapM perParent (parentNames ress)+  where+    parentNames trees = concat+        [ name : parentNames children+        | ResourceParent name _ _ _ children <- trees+        ]+    perParent name = do+        exists <- nestedInstanceExists ''RouteAttrsNested =<< resolveRouteCon name+        if exists+            then pure []+            else mkRouteAttrsInstanceFor cxt (applyTyArgs (ConT (mkName name)) tyargs) name ress++goTree :: Maybe String -> (Pat -> Pat) -> ResourceTree a -> Q [Clause]+goTree mtarget front (ResourceLeaf res) =+    case mtarget of+        Nothing ->+            return $ toList $ goRes front res+        Just _ ->+            return []+goTree (Just target) front (ResourceParent name _check _attrs _pieces trees)+    | target /= name = concat <$> mapM (goTree (Just target) front) trees+goTree mtarget front (ResourceParent name _check _attrs pieces trees) = do+    doesNestedInstanceExist <- nestedInstanceExists ''RouteAttrsNested =<< resolveRouteCon name++    if doesNestedInstanceExist+        then do+            x <- newName "x"+            pure [Clause [front (conPCompat (mkName name) (ignored (VarP x)))] (NormalB $ VarE 'routeAttrsNested `AppE` VarE x) []]+        else do+            -- We only reach this clause when @mtarget@ is 'Nothing' (full+            -- instance) or @Just name@ (we found the focus target); clause 2+            -- above peeled off the non-matching @Just other@ case. Either way+            -- the remaining subtree is generated unfocused (@Nothing@). The+            -- focus target itself is the route boundary, so its own+            -- constructor is not prepended (@front@); ordinary parents in the+            -- full instance do prepend theirs (@front'@).+            let front'' =+                    if Just name == mtarget+                        then front+                        else front'+            concat <$> mapM (goTree Nothing front'') trees+  where+    ignored = (replicate toIgnore WildP ++) . return+    toIgnore = length $ filter isDynamic pieces+    isDynamic Dynamic{} = True+    isDynamic Static{} = False+    front' = front . conPCompat (mkName name)+                   . ignored++goRes :: (Pat -> Pat) -> Resource a -> Maybe Clause+goRes front Resource {..} = do+    guard (not (null resourceAttrs))+    return $ Clause+        [front $ RecP (mkName resourceName) []]+        (NormalB $ VarE 'Set.fromList `AppE` ListE (map toText resourceAttrs))+        []+  where+    toText s = VarE 'Text.pack `AppE` LitE (StringL s)
+ src/Yesod/Routes/TH/Types.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveLift #-}++-- | Warning! This module is considered internal and may have breaking changes+module Yesod.Routes.TH.Types+    ( -- * Data types+      Resource (..)+    , ResourceTree (..)+    , Piece (..)+    , Dispatch (..)+    , CheckOverlap+    , FlatResource (..)+    , ParentDetails (..)+      -- * Route datatype type arguments+    , TyArgs (..)+    , toTyArgs+    , tyArgsList+    , tyArgsTypes+    , tyArgsBinders+    , tyArgsArity+    , hasTyArgs+    , applyTyArgs+      -- ** Helper functions+    , resourceMulti+    , resourceTreePieces+    , resourceTreeName+    , flatten+    ) where++import Language.Haskell.TH.Syntax+import Data.List (foldl')+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Set (Set)+-- Provides Lift instance for Set in older versions of GHC+import Instances.TH.Lift ()++-- | The type arguments of a route datatype, paired with the source 'Name' each+-- was derived from. A monomorphic site like @App@ has 'NoTyArgs'; a+-- parameterized one like @MySub subsite@ has 'SomeTyArgs'.+--+-- Carrying the (non-)emptiness in the type — rather than as a bare list with a+-- separate @null@ check — keeps \"are there type args?\" and \"what are they?\"+-- a single fact, so the populated branch hands you the 'NonEmpty' directly.+--+-- @since 1.7.0.0+data TyArgs+    = NoTyArgs+    | SomeTyArgs (NonEmpty (Type, Name))+    deriving (Eq, Show)++-- | Build 'TyArgs' from a list of (type, source-name) pairs.+--+-- @since 1.7.0.0+toTyArgs :: [(Type, Name)] -> TyArgs+toTyArgs []       = NoTyArgs+toTyArgs (x : xs) = SomeTyArgs (x :| xs)++-- | The type arguments as a plain list (empty for 'NoTyArgs').+--+-- @since 1.7.0.0+tyArgsList :: TyArgs -> [(Type, Name)]+tyArgsList NoTyArgs        = []+tyArgsList (SomeTyArgs ne) = NonEmpty.toList ne++-- | Just the 'Type's of the arguments, in order.+--+-- @since 1.7.0.0+tyArgsTypes :: TyArgs -> [Type]+tyArgsTypes = map fst . tyArgsList++-- | Just the source 'Name's of the arguments, in order.+--+-- @since 1.7.0.0+tyArgsBinders :: TyArgs -> [Name]+tyArgsBinders = map snd . tyArgsList++-- | How many type arguments there are.+--+-- @since 1.7.0.0+tyArgsArity :: TyArgs -> Int+tyArgsArity NoTyArgs        = 0+tyArgsArity (SomeTyArgs ne) = NonEmpty.length ne++-- | Whether there are any type arguments (i.e. the site is parameterized).+--+-- @since 1.7.0.0+hasTyArgs :: TyArgs -> Bool+hasTyArgs NoTyArgs      = False+hasTyArgs SomeTyArgs {} = True++-- | Apply the type arguments to a head type (e.g. a route\/subroute type+-- constructor), left to right. This replaces the ad-hoc+-- @'foldl'' 'AppT' con ('fst' '<$>' tyargs)@ that recurred across the+-- generators.+--+-- @since 1.7.0.0+applyTyArgs :: Type -> TyArgs -> Type+applyTyArgs t = foldl' AppT t . tyArgsTypes++data ResourceTree typ+    = ResourceLeaf (Resource typ)+    | ResourceParent String CheckOverlap (Set String) [Piece typ] [ResourceTree typ]+    deriving (Lift, Show, Functor, Foldable, Traversable)++resourceTreePieces :: ResourceTree typ -> [Piece typ]+resourceTreePieces (ResourceLeaf r) = resourcePieces r+resourceTreePieces (ResourceParent _ _ _ x _) = x++resourceTreeName :: ResourceTree typ -> String+resourceTreeName (ResourceLeaf r) = resourceName r+resourceTreeName (ResourceParent x _ _ _ _) = x++data Resource typ = Resource+    { resourceName :: String+    , resourcePieces :: [Piece typ]+    , resourceDispatch :: Dispatch typ+    , resourceAttrs :: [String]+    , resourceCheck :: CheckOverlap+    }+    deriving (Lift, Show, Functor, Foldable, Traversable)++type CheckOverlap = Bool++data Piece typ = Static String | Dynamic typ+    deriving (Lift, Show, Functor, Foldable, Traversable)++data Dispatch typ =+    Methods+        { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end+        , methodsMethods :: [String] -- ^ supported request methods+        }+    | Subsite+        { subsiteType :: typ+        , subsiteFunc :: String+        }+    deriving (Lift, Show, Functor, Foldable, Traversable)++resourceMulti :: Resource typ -> Maybe typ+resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t+resourceMulti _ = Nothing++-- | The details of a 'ResourceParent' gathered for a flattened resource: the+-- parent's name, its path pieces, and the route attributes it contributes to+-- its descendants.+--+-- @since 1.7.0.0+data ParentDetails a = ParentDetails+    { pdName :: String+    , pdPieces :: [Piece a]+    , pdAttrs :: Set String+    } deriving (Show)++data FlatResource a = FlatResource+    { frParentDetails :: [ParentDetails a]+    , frName :: String+    , frPieces :: [Piece a]+    , frDispatch :: Dispatch a+    , frCheck :: Bool+    } deriving (Show)++flatten :: [ResourceTree a] -> [FlatResource a]+flatten =+    concatMap (go id True)+  where+    go front check' (ResourceLeaf (Resource a b c _ check)) =+        [FlatResource (front []) a b c (check' && check)]+    go front check' (ResourceParent name check attrs pieces children) =+        concatMap (go (front . ((ParentDetails name pieces attrs):)) (check && check')) children
− test.hs 
@@ -1,5 +0,0 @@-import Test.Hspec-import qualified YesodCoreTest--main :: IO ()-main = hspec YesodCoreTest.specs
+ test/Hierarchy.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | Whole-tree end of the @Hierarchy@ split-codegen fixture: generates the+-- full @RenderRoute@\/@RouteAttrs@\/@ParseRoute@\/@YesodDispatch@ instances for+-- the shared tree (from "Hierarchy.ResourceTree") in one set of splices, and+-- supplies every leaf handler. The @Hierarchy.*@ sibling modules instead each+-- emit one focused nested fragment; importing them here checks the per-fragment+-- and whole-tree codegen agree. Drives the @test-routes@ suite's @hierarchy@ spec.+module Hierarchy+    ( hierarchy+    -- to avoid warnings+    , deleteDelete2+    , deleteDelete3+    , testRouteDatatype+    ) where++import Yesod.Core+import Test.Hspec+import Test.HUnit+import Yesod.Routes.TH+import Yesod.Routes.Class+import Language.Haskell.TH.Syntax+import Data.Text (Text)+import qualified Data.Set as Set+import Hierarchy.Admin+import Hierarchy.ResourceTree+import Hierarchy.Nest+import Hierarchy.Nest2+import Hierarchy.Nest3+import Hierarchy.Nest2.NestInner++-- | Trivial handler synonym kept only for the @deleteDelete2@\/@deleteDelete3@+-- placeholder handlers below (which exist solely to silence+-- not-in-scope warnings for routes whose handlers are never invoked here).+type Handler site a = a++do+    fmap concat $ sequence+        [ mkRenderRouteInstanceOpts defaultOpts [] NoTyArgs (ConT ''Hierarchy) hierarchyResourcesWithType+        , pure <$> mkRouteAttrsInstance [] (ConT ''Hierarchy) hierarchyResourcesWithType+        , mkParseRouteInstance NoTyArgs [] (ConT ''Hierarchy) hierarchyResourcesWithType+        , mkYesodDispatchOpts defaultOpts "Hierarchy" hierarchyResources+        ]++instance Yesod Hierarchy+++getAfter :: HandlerFor site Text+getAfter = pure "after"+getHomeR :: HandlerFor site Text+getHomeR = pure "homer"++getBackwardsR :: Int -> HandlerFor site Text+getBackwardsR _i = pure "backwards"++getGet3 :: HandlerFor site Text+getGet3 = pure "getget3"++postPost3 :: HandlerFor site Text+postPost3 = pure "postPost3"++getNestInnerIndexR :: HandlerFor site Text+getNestInnerIndexR = pure "getNestInnerIndexR"++getGetPostR :: HandlerFor site Text+getGetPostR = pure "getGetPostR"++postGetPostR :: HandlerFor site Text+postGetPostR = pure "postGetPostR"++getGet2 :: HandlerFor site Text+getGet2 = pure "getGet2"++postPost2 :: HandlerFor site Text+postPost2 = pure "postPost2"++getSpacedR :: HandlerFor site Text+getSpacedR = pure "getSpacedR"++getAdminRootR :: Int -> HandlerFor site Text+getAdminRootR _ = pure "getAdminRootR"++getLoginR :: Int -> HandlerFor site Text+getLoginR _ = pure "getLoginR"++postLoginR :: Int -> HandlerFor site Text+postLoginR _ = pure "postLoginR"++getTableR :: Int -> Text -> HandlerFor site Text+getTableR _ _ = pure "getTableR"++deleteDelete2 :: Int -> Handler site String; deleteDelete2 = const "delete"+deleteDelete3   :: Int -> Handler site String; deleteDelete3 = const "delete"++hierarchy :: Spec+hierarchy = describe "hierarchy" $ do+    it "nested with spacing" $+        renderRoute (NestR SpacedR) @?= (["nest", "spaces"], [])+    it "renders root correctly" $+        renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], [])+    it "renders table correctly" $+        renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], [])+    describe "parseRoute" $ do+        let parseNothing = Nothing :: Maybe (Route Hierarchy)+        describe "HomeR" $ do+            it "works" $ do+                parseRoute ([], []) @?= Just HomeR+            it "with extraneous query params" $ do+                parseRoute ([], [("foo", "bar")]) @?= Just HomeR+        describe "AdminR" $ do+            it "works" $ do+                parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR)+            it "fails with extra character" $ do+                parseRoute (["admin!", "5"], []) @?= parseNothing+            it "works with a subroute with param" $ do+                parseRoute (["admin", "6", "table", "hello"], []) @?= Just (AdminR 6 (TableR "hello"))+            describe "parseNestedRoute" $ do+                it "works" $ do+                    parseRouteNested ([], []) @?= Just AdminRootR+                it "works with param" $ do+                    parseRouteNested (["table", "hello"], []) @?= Just (TableR "hello")+        describe "NestR" $ do+            it "fails because there's no top-level handler" $ do+                parseRoute (["nest"], []) @?= parseNothing+            it "works for SpacedR" $ do+                parseRoute (["nest", "spaces"], []) @?= Just (NestR SpacedR)+            it "works with parseRouteNested" $ do+                parseRouteNested (["spaces"], []) @?= Just SpacedR+            describe "Nest2" $ do+                it "works" $ do+                    parseRoute (["nest", "nest2"], []) @?= Just (NestR (Nest2 GetPostR))+                describe "NestInner" $ do+                    it "works" $ do+                        parseRoute (["nest", "nest2", "nest-inner"], []) @?= Just (NestR (Nest2 (NestInner NestInnerIndexR)))+    describe "parseRouteNested" $ do+        describe "NestInner" $ do+            it "works" $ do+                parseRouteNested ([], []) @?= Just NestInnerIndexR+    describe "routeAttrs" $ do+        it "inherited attributes" $ do+            routeAttrs (NestR SpacedR) @?= Set.fromList ["NestingAttr", "NonNested"]+        it "pair attributes" $+            routeAttrs (AfterR After) @?= Set.fromList ["parent", "child", "key=value2"]++        describe "NestingAttr inherits properly" $ do+            it "routeAttrs" $ do+                routeAttrs (NestR (Nest2 GetPostR)) @?= Set.fromList ["NestingAttr"]+            it "routeAttrsNested" $ do+                routeAttrsNested GetPostR @?= Set.fromList ["NestingAttr"]+            it "routeAttrsNested InnerNest" $ do+                routeAttrsNested NestInnerIndexR @?= Set.fromList ["NestingAttr"]+++-- This value should compile if all routes are present as expected.+testRouteDatatype :: Route Hierarchy -> Int+testRouteDatatype r =+    case r of+        HomeR -> 0+        BackwardsR _ -> 1+        AdminR _ sub ->+            case sub of+                AdminRootR -> 0+                LoginR -> 0+                TableR _ -> 1+        NestR sub -> testNestR sub+        -- NOTE: This is a bug in the behavior of the parser. See issue+        -- https://github.com/yesodweb/yesod/issues/1886+        --+        -- Nest3, by layout, should be under `NestR`. However, since there+        -- is a comment on column 0, this causes the parser to reset the+        -- column count.+        Nest3 sub ->+            case sub of+                Get3 -> 0+                Post3 -> 0+        AfterR sub ->+            case sub of+                After -> 0++testNestR :: NestR -> Int+testNestR sub =+    case sub of+        SpacedR -> 1+        Nest2 sub' ->+            case sub' of+                GetPostR -> 0+                Get2 -> 0+                Post2 -> 0+                NestInner sub'' ->+                    case sub'' of+                        NestInnerIndexR -> 0
+ test/Hierarchy/Admin.hs view
@@ -0,0 +1,29 @@+{-# language TemplateHaskell, ViewPatterns, OverloadedStrings, TypeFamilies #-}++-- | @Hierarchy@ split fragment focused on the @AdminR@ parent. Shows the+-- finer-grained helpers — @mkRenderRouteInstanceOpts@ /+-- @mkRouteAttrsInstanceFor@ / @mkParseRouteInstanceFor@ each scoped to+-- @"AdminR"@ — emitting that one fragment's instances against the shared+-- @hierarchyResourcesWithType@ tree, rather than the whole-tree splice in+-- "Hierarchy".+module Hierarchy.Admin where++import Yesod.Routes.TH+import Hierarchy.ResourceTree+import Language.Haskell.TH+import Data.Text (Text)++mkRenderRouteInstanceOpts+    (setFocusOnNestedRoute "AdminR" defaultOpts)+    []+    NoTyArgs+    (ConT ''Hierarchy)+    hierarchyResourcesWithType+mkRouteAttrsInstanceFor+    []+    (ConT ''AdminR)+    "AdminR"+    $ hierarchyResourcesWithType+mkParseRouteInstanceFor+    "AdminR"+    $ hierarchyResourcesWithType
+ test/Hierarchy/Nest.hs view
@@ -0,0 +1,29 @@+{-# language TemplateHaskell #-}+{-# language ViewPatterns #-}+{-# language OverloadedStrings #-}+{-# language TypeFamilies #-}++-- | @Hierarchy@ split fragment focused on the top-level nested parent @NestR@+-- (which itself contains @Nest2@\/@Nest3@). Uses the canonical+-- @mkYesodDataOpts@ with @setFocusOnNestedRoute "NestR"@ to emit just that+-- fragment's route datatype + render\/attrs\/parse instances — the same+-- higher-level entry point a full Yesod site uses to split route compilation+-- across modules (see @yesod-core\/docs\/split-route-compilation.md@). Imports+-- the deeper @Nest2@\/@Nest3@\/@NestInner@ fragment modules so their+-- separately-emitted instances are in scope for @NestR@ to delegate to.+--+-- (Sibling fragments "Hierarchy.Admin", "Hierarchy.Nest2" and+-- "Hierarchy.Nest2.NestInner" instead drive the underlying+-- @mkRenderRouteInstanceOpts@ \/ @mkRouteAttrsInstanceFor@ \/+-- @mkParseRouteInstanceFor@ builders directly, so the route-level generators+-- that @mkYesodDataOpts@ bundles stay covered too.)+module Hierarchy.Nest where++import Yesod.Routes.TH+import Hierarchy.ResourceTree+import Hierarchy.Nest3 ()+import Hierarchy.Nest2+import Hierarchy.Nest2.NestInner+import Yesod.Core++mkYesodDataOpts (setFocusOnNestedRoute "NestR" defaultOpts) "Hierarchy" hierarchyResources
+ test/Hierarchy/Nest2.hs view
@@ -0,0 +1,28 @@+{-# language TemplateHaskell, OverloadedStrings, ViewPatterns, TypeFamilies #-}++-- | @Hierarchy@ split fragment focused on the @Nest2@ parent. Emits @Nest2@'s+-- render\/attrs\/parse instances against the shared @hierarchyResourcesWithType@.+-- The top-of-module @do@ block is a compile-time assertion: it calls+-- @parseRouteNested@ for the deeper @NestInner@ fragment (whose instance is+-- emitted in "Hierarchy.Nest2.NestInner") and @fail@s the splice if parsing the+-- empty path does not yield @NestInnerIndexR@ — pinning cross-module nested parse.+module Hierarchy.Nest2 where++import Yesod.Routes.Class+import Yesod.Routes.TH+import Hierarchy.ResourceTree+import Language.Haskell.TH+import Hierarchy.Nest3 ()+import Hierarchy.Nest2.NestInner++do+    let works = parseRouteNested ([], []) :: Maybe NestInner+    case works of+        Nothing ->+            fail "parsing fails"+        Just NestInnerIndexR ->+            pure []++mkRenderRouteInstanceOpts (setFocusOnNestedRoute "Nest2" defaultOpts) [] NoTyArgs (ConT ''Hierarchy) hierarchyResourcesWithType+mkRouteAttrsInstanceFor [] (ConT ''Nest2) "Nest2" $ hierarchyResourcesWithType+mkParseRouteInstanceFor "Nest2" $ hierarchyResourcesWithType
+ test/Hierarchy/Nest2/NestInner.hs view
@@ -0,0 +1,23 @@+{-# language TemplateHaskell #-}+{-# language ViewPatterns, OverloadedStrings #-}+{-# language TypeFamilies #-}++-- | @Hierarchy@ split fragment focused on the deepest nested parent+-- @NestInner@ (under @NestR@ > @Nest2@). Emits its render\/attrs\/parse+-- instances via @setFocusOnNestedRoute "NestInner"@ + the @*For@ helpers; the+-- @ParseRouteNested NestInner@ instance is what "Hierarchy.Nest2" asserts+-- against at compile time.+module Hierarchy.Nest2.NestInner where++import Yesod.Routes.TH+import Hierarchy.ResourceTree+import Language.Haskell.TH++mkRenderRouteInstanceOpts+    (setFocusOnNestedRoute "NestInner" defaultOpts)+    []+    NoTyArgs+    (ConT ''Hierarchy)+    hierarchyResourcesWithType+mkRouteAttrsInstanceFor [] (ConT ''NestInner) "NestInner" $ hierarchyResourcesWithType+mkParseRouteInstanceFor "NestInner" $ hierarchyResourcesWithType
+ test/Hierarchy/Nest3.hs view
@@ -0,0 +1,16 @@+{-# language TemplateHaskell #-}+{-# language ViewPatterns #-}+{-# language OverloadedStrings #-}+{-# language TypeFamilies #-}++-- | @Hierarchy@ split fragment focused on the @Nest3@ parent. Demonstrates+-- @mkYesodDataOpts@ with @setFocusOnNestedRoute "Nest3"@ emitting just that+-- nested fragment's route datatype + instances, separate from the whole-tree+-- splice in "Hierarchy". Shares @hierarchyResources@ from "Hierarchy.ResourceTree".+module Hierarchy.Nest3 where++import Yesod.Routes.TH+import Hierarchy.ResourceTree+import Yesod.Core++mkYesodDataOpts (setFocusOnNestedRoute "Nest3" defaultOpts) "Hierarchy" hierarchyResources
+ test/Hierarchy/ResourceTree.hs view
@@ -0,0 +1,54 @@+{-# language TemplateHaskell #-}+{-# language QuasiQuotes #-}++-- | Shared resource tree + foundation type for the @Hierarchy@ split-codegen+-- fixture. The @Hierarchy.*@ sibling modules each focus on one nested parent+-- (NestR, Nest2, Nest3, NestInner, AdminR) via @setFocusOnNestedRoute@ and emit+-- that fragment's instances separately, while "Hierarchy" itself emits the+-- whole-tree instances; keeping the tree here lets every splice share it+-- without tripping the TH stage restriction. Used by the @test-routes@ suite.+module Hierarchy.ResourceTree where++import Yesod.Routes.Parse+import Language.Haskell.TH (Type)+import Yesod.Routes.TH++data Hierarchy = Hierarchy++hierarchyResources :: [ResourceTree String]+hierarchyResources = [parseRoutes|+/ HomeR GET++----------------------------------------++/!#Int BackwardsR GET++/admin/#Int AdminR:+    /            AdminRootR GET+    /login       LoginR     GET POST+    /table/#Text TableR     GET++/nest/ NestR !NestingAttr:++  /spaces      SpacedR   GET !NonNested++  /nest2 Nest2:+    /           GetPostR  GET POST+    /get        Get2      GET+    /post       Post2         POST+    /nest-inner NestInner:+        /       NestInnerIndexR GET+-- lol++  /nest3 Nest3:+    /get        Get3      GET+    /post       Post3         POST+--    /#Int       Delete3            DELETE++/afterwards AfterR !parent !key=value1:+  /             After     GET !child !key=value2++|]++hierarchyResourcesWithType :: [ResourceTree Type]+hierarchyResourcesWithType = map (fmap parseType) hierarchyResources
+ test/Route/DeepAritySpec.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Exercises the reify/'typeArity' path that 'assertNestedSubArity' runs+-- inside 'mkNestedDispatchInstanceWith'\'s recursion — the part the pure+-- 'checkNestedSubArity' unit tests in "Route.SubDispatchAritySpec" can't reach.+-- A 2nd-level-or-deeper nested datatype whose arity doesn't match the site's+-- type-argument count must be caught by the guard's @fail@ (an actionable+-- 'ArityMismatch') rather than slip through to a cryptic kind error in+-- generated code.+module Route.DeepAritySpec (spec) where++import Test.Hspec+import Language.Haskell.TH (recover)+import Yesod.Routes.TH.Internal+    ( assertNestedSubArity+    , resolveRouteCon+    , typeArity+    , ArityCallSite(..)+    , SubsiteName(..)+    , SubsiteArity(..)+    )+import Route.DeepArityTypes (ParamSite, MatchingDeepR, WrongDeepR)++-- | The reified arities feeding the guard, extracted at compile time through+-- the same 'typeArity' call 'assertNestedSubArity' makes.+reifiedArities :: (Int, Int, Int)+reifiedArities =+    $(do+        a <- typeArity ''ParamSite+        b <- typeArity ''MatchingDeepR+        c <- typeArity ''WrongDeepR+        [| (a, b, c) |])++-- | 'True' iff the arity guard fired its @fail@ for a (site arity 1) vs.+-- (@WrongDeepR@ arity 0) pairing — i.e. the deep mismatch was caught at the+-- guard rather than escaping into ill-kinded generated code.+wrongArityCaught :: Bool+wrongArityCaught =+    $(do+        rc <- resolveRouteCon "WrongDeepR"+        recover [| True |] $ do+            assertNestedSubArity TopLevelCall (SubsiteName "ParamSite") (SubsiteArity 1) rc+            [| False |])++-- | 'True' iff a matching (arity 1 vs. 1) pairing passes the guard cleanly.+matchingArityOk :: Bool+matchingArityOk =+    $(do+        rc <- resolveRouteCon "MatchingDeepR"+        recover [| False |] $ do+            assertNestedSubArity TopLevelCall (SubsiteName "ParamSite") (SubsiteArity 1) rc+            [| True |])++spec :: Spec+spec = describe "deep nested-route arity guard (reify path)" $ do+    it "reifies datatype arities used by the guard" $+        reifiedArities `shouldBe` (1, 1, 0)+    it "catches a deep arity mismatch with the actionable guard (not a kind error)" $+        wrongArityCaught `shouldBe` True+    it "lets a correctly-parameterized deep nested datatype through" $+        matchingArityOk `shouldBe` True
+ test/Route/DeepArityTypes.hs view
@@ -0,0 +1,15 @@+-- | Datatypes for "Route.DeepAritySpec", in their own module so the spec's+-- compile-time splices can 'reify' them — a datatype defined in the same module+-- as a top-level splice is not yet in the type environment at a 'reify'.+module Route.DeepArityTypes+    ( ParamSite (..)+    , MatchingDeepR (..)+    , WrongDeepR (..)+    ) where++-- A parameterized site (arity 1) plus two candidate nested datatypes: one whose+-- arity matches (1) and one whose arity is wrong (0). These stand in for a+-- deeply-nested subroute reached by the dispatch recursion.+data ParamSite a = ParamSite+data MatchingDeepR a = MatchingDeepR+data WrongDeepR = WrongDeepR
+ test/Route/DiscoveryModeSpec.hs view
@@ -0,0 +1,49 @@+-- | Unit tests for the 'discoveryMode' classifier. It is a pure, total+-- function but previously had no direct coverage; every behavioural test only+-- exercised it indirectly through generated code.+module Route.DiscoveryModeSpec (spec) where++import Test.Hspec+import Yesod.Routes.TH.RenderRoute+    ( defaultOpts+    , setParameterizedSubroute+    , setFocusOnNestedRoute+    , DiscoveryMode (..)+    , discoveryMode+    )+import Yesod.Routes.TH.Types (TyArgs, toTyArgs)+import Language.Haskell.TH (Type (ConT), mkName)++-- | A site with no type parameters ('hasTyArgs' 'False').+noArgs :: TyArgs+noArgs = toTyArgs []++-- | A site with one type parameter ('hasTyArgs' 'True').+someArgs :: TyArgs+someArgs = toTyArgs [(ConT (mkName "Int"), mkName "a")]++spec :: Spec+spec = describe "discoveryMode" $ do+    -- Dimension 1: no type args (a monomorphic site is always nested).+    it "is NestedDiscovery for a monomorphic site, even with all opts off" $+        discoveryMode defaultOpts noArgs `shouldBe` NestedDiscovery++    -- Dimensions 2/3 off, has type args: the backwards-compatible inline case.+    it "is InlineCompat for a parameterized site with default opts" $+        discoveryMode defaultOpts someArgs `shouldBe` InlineCompat++    -- Dimension 2: roParameterizedSubroute in the parameterized case.+    it "is NestedDiscovery for a parameterized site when parameterized-subroute is set" $+        discoveryMode (setParameterizedSubroute True defaultOpts) someArgs+            `shouldBe` NestedDiscovery++    -- Dimension 3: roFocusOnNestedRoute in the parameterized case.+    it "is NestedDiscovery for a parameterized site when focusing on a nested route" $+        discoveryMode (setFocusOnNestedRoute "Target" defaultOpts) someArgs+            `shouldBe` NestedDiscovery++    it "stays NestedDiscovery for a monomorphic site with the flags set" $ do+        discoveryMode (setParameterizedSubroute True defaultOpts) noArgs+            `shouldBe` NestedDiscovery+        discoveryMode (setFocusOnNestedRoute "Target" defaultOpts) noArgs+            `shouldBe` NestedDiscovery
+ test/Route/FallthroughSpec.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns#-}+++-- | The nested-route fallthrough contract for a top-level site, generated with+-- @setNestedRouteFallthrough True@. Two same-prefix parents share @\/foo@+-- (@FirstFooR@ index-only, @SecondFooR@ with deeper children). With fallthrough+-- on, a request missing inside @FirstFooR@ continues to the sibling rather than+-- committing. Asserts at both layers: @parseRoute@ falls through to the right+-- constructor, and a WAI dispatch round-trip (via 'YesodCoreTest.RuntimeHarness')+-- serves the expected handler.+module Route.FallthroughSpec where++import Network.Wai+import Yesod.Core+import Test.Hspec+import Data.ByteString.Lazy (ByteString)++import YesodCoreTest.RuntimeHarness (assertRequestRaw)++data App = App++do+    let resources = [parseRoutesNoCheck|++/ HomeR+/foo FirstFooR:+    /   FooIndexR+/foo SecondFooR:+    /blah FooBlahR+    /baz  FooBaz1R:+        /   FooBazIndexR+    /baz    FooBaz2R:+        /foo    FooBaz2FooR++    |]++    let opts = setNestedRouteFallthrough True defaultOpts+    mkYesodOpts opts "App" resources++instance Yesod App where+    messageLoggerSource = mempty++handleFooBlahR :: HandlerFor site String+handleFooBlahR = pure "FooBlahR"++handleHomeR :: HandlerFor site String+handleHomeR = pure "HomeR"++handleFooBaz2FooR :: HandlerFor site String+handleFooBaz2FooR = pure "FooBaz2FooR"++handleFooBazIndexR :: HandlerFor site String+handleFooBazIndexR = pure "FooBazIndexR"++handleFooIndexR :: HandlerFor site String+handleFooIndexR = pure "FooIndexR"++spec :: Spec+spec = do+    describe "parseRoute" $ do+        let routeShouldParse path result =+                parseRoute (path, []) `shouldBe` Just result+            routeShouldNotParse path =+                parseRoute (path, []) `shouldBe` (Nothing :: Maybe (Route App))+        it "matches the first parent without falling through" $ do+            routeShouldParse ["foo"] (FirstFooR FooIndexR)+        it "can fall through" $ do+            routeShouldParse ["foo", "blah"] (SecondFooR FooBlahR)+        it "nested fallthrough works too" $ do+            routeShouldParse ["foo", "baz", "foo"] (SecondFooR (FooBaz2R FooBaz2FooR))+        it "can fail" $ do+            routeShouldNotParse ["asdf"]++    describe "Dispatch" $ do+        it "/" $ do+            testRequestIO+                200+                defaultRequest+                    { pathInfo = []+                    }+                (Just "HomeR")+        it "/foo" $ do+            testRequestIO+                200+                defaultRequest+                    { pathInfo = ["foo"]+                    }+                (Just "FooIndexR")++testRequestIO :: HasCallStack => Int -- ^ http status code+            -> Request+            -> Maybe ByteString -- ^ expected body+            -> IO ()+testRequestIO status req mexpected =+    assertRequestRaw (toWaiApp App) req status mexpected
+ test/Route/FocusLeafConsSpec.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TemplateHaskell #-}+-- | This module pins the constructor set of the generated @FocusNestR@+-- datatype exactly, so escalate an incomplete 'describeFocus' to an error.+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Regression test for 'mkRouteConsOpts' in focus (module-split) mode.+--+-- Previously the focused branch dropped every 'ResourceLeaf' among the+-- target's children (returning @([], [])@ for leaves), so the focused+-- datatype was generated without its leaf constructors. Here we splice a+-- datatype built directly from 'mkRouteConsOpts'' focused output, then assert+-- its constructor set is /exactly/ what we expect via a total 'case':+--+--   * a /missing/ constructor fails the pattern reference (a name that isn't+--     in scope), and+--   * an /extra/ constructor makes 'describeFocus' non-exhaustive, which+--     @-Werror=incomplete-patterns@ (set above) turns into a compile error.+--+-- So this module fails to build unless @FocusNestR@ has precisely the two leaf+-- constructors @FocusIndexR@ and @FocusShowR Int@.+module Route.FocusLeafConsSpec (spec) where++import Test.Hspec+import Language.Haskell.TH+import Yesod.Routes.TH.Types+import Yesod.Routes.TH.RenderRoute+    ( mkRouteConsOpts+    , defaultOpts+    , setFocusOnNestedRoute+    )++data App = App++-- | A nested route @FocusNestR@ whose children are two leaves. We build the+-- focused datatype from 'mkRouteConsOpts' and declare it by hand from the+-- returned constructors.+$(do+    let leaf name pieces =+            ResourceLeaf (Resource name pieces (Methods Nothing ["GET"]) [] True)+        parent name pieces =+            ResourceParent name True mempty pieces+        routes =+            [ leaf "FocusHomeR" []+            , parent "FocusNestR" []+                [ leaf "FocusIndexR" []+                , leaf "FocusShowR" [Dynamic (ConT ''Int)]+                ]+            ]+    (cons, _decs) <-+        mkRouteConsOpts+            (setFocusOnNestedRoute "FocusNestR" defaultOpts)+            []+            NoTyArgs+            (ConT ''App)+            routes+    pure [DataD [] (mkName "FocusNestR") [] Nothing cons [DerivClause Nothing [ConT ''Show]]])++-- | Total over every constructor of the generated @FocusNestR@. Naming each+-- constructor exactly once is what makes this a complete-set assertion: see+-- the module header for how missing/extra constructors are each rejected at+-- compile time.+describeFocus :: FocusNestR -> String+describeFocus r = case r of+    FocusIndexR  -> "FocusIndexR"+    FocusShowR n -> "FocusShowR " ++ show n++spec :: Spec+spec = describe "mkRouteConsOpts (focus mode)" $+    it "generates exactly the focused route's leaf constructors" $ do+        -- The real assertion is at compile time (see 'describeFocus'); these+        -- just exercise the generated constructors.+        describeFocus FocusIndexR    `shouldBe` "FocusIndexR"+        describeFocus (FocusShowR 7) `shouldBe` "FocusShowR 7"
+ test/Route/InlineParseClausesSpec.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++-- | Unit tests for 'buildInlineParseClauses', the pure (effect-free) core of+-- the backwards-compatible inline @parseRoute@ codegen. Because it is pure —+-- it takes a deterministic fresh-name supply instead of 'Q'\'s 'newName' and+-- builds AST directly rather than through quotation brackets — its '[Clause]'+-- output can be asserted on directly, with no splicing, compilation, or+-- 'runQ'. This is the testability win from extracting the pure builder out of+-- 'generateParseRouteClausesInline'.+module Route.InlineParseClausesSpec (spec) where++import Test.Hspec+import Data.Maybe (catMaybes)+import Language.Haskell.TH+import Web.PathPieces (fromPathPiece)+import Yesod.Routes.TH.Types+import Yesod.Routes.TH.ParseRoute (buildInlineParseClauses)+import Route.PureQ (runPureQ)++-- | Run the pure builder at the top level (no wrapping), the way+-- 'generateParseRouteClausesInline' invokes it.+run :: ResourceTree Type -> [Clause]+run t = runPureQ (buildInlineParseClauses id t)++leaf :: String -> [Piece Type] -> Dispatch Type -> ResourceTree Type+leaf name pieces d = ResourceLeaf (Resource name pieces d [] True)++methods :: [String] -> Dispatch Type+methods = Methods Nothing++parent :: String -> [Piece Type] -> [ResourceTree Type] -> ResourceTree Type+parent name pieces = ResourceParent name True mempty pieces++-- | Assert there is exactly one clause and hand it to the continuation.+withOnlyClause :: [Clause] -> (Clause -> Expectation) -> Expectation+withOnlyClause cs k =+    case cs of+        [c] -> k c+        _   -> expectationFailure $ "expected exactly one clause, got " <> show (length cs)++-- | Variables bound by a @fromPathPiece@ view pattern, descending through the+-- list\/tuple\/constructor patterns the inline builder nests them in.+boundDynVars :: Pat -> [Name]+boundDynVars (ViewP (VarE f) inner)+    | f == 'fromPathPiece = simpleVars inner+boundDynVars p = concatMap boundDynVars (subPats p)++-- | Plain 'VarP' names anywhere within a pattern.+simpleVars :: Pat -> [Name]+simpleVars (VarP n) = [n]+simpleVars p        = concatMap simpleVars (subPats p)++-- | The immediate sub-patterns of a pattern (only the shapes the inline+-- builder produces need handling).+subPats :: Pat -> [Pat]+subPats (TupP ps)     = ps+subPats (ListP ps)    = ps+subPats (ViewP _ p)   = [p]+subPats (ParensP p)   = [p]+subPats (BangP p)     = [p]+subPats (TildeP p)    = [p]+subPats (AsP _ p)     = [p]+subPats (SigP p _)    = [p]+#if MIN_VERSION_template_haskell(2,18,0)+subPats (ConP _ _ ps) = ps+#else+subPats (ConP _ ps)   = ps+#endif+subPats _             = []++-- | The variables referenced in an expression.+usedVars :: Exp -> [Name]+usedVars (VarE n) = [n]+usedVars e        = concatMap usedVars (subExps e)++-- | The match alternatives of the top-level expression, when it is a @case@+-- (the shape a parent's committing clause produces). 'Nothing' otherwise.+caseMatches :: Exp -> Maybe [Match]+caseMatches (CaseE _ ms) = Just ms+caseMatches _            = Nothing++-- | The body expression of a clause that has no @where@ bindings.+clauseExp :: Clause -> Exp+clauseExp (Clause _ body _) = clauseBodyExp body++-- | Whether a match alternative is the catch-all @_ -> Nothing@ fallback.+isNothingFallback :: Match -> Bool+isNothingFallback (Match WildP (NormalB (ConE n)) []) = n == 'Nothing+isNothingFallback _                                    = False++-- | The immediate sub-expressions of an expression.+subExps :: Exp -> [Exp]+subExps (AppE a b)       = [a, b]+subExps (AppTypeE e _)   = [e]+subExps (InfixE ma _ mb) = catMaybes [ma, mb]+subExps (UInfixE a b c)  = [a, b, c]+subExps (ParensE e)      = [e]+subExps (LamE _ e)       = [e]+subExps (SigE e _)       = [e]+subExps (CondE a b c)    = [a, b, c]+subExps (CaseE e ms)     = e : [me | Match _ (NormalB me) _ <- ms]+subExps (ListE es)       = es+#if MIN_VERSION_template_haskell(2,16,0)+subExps (TupE mes)       = catMaybes mes+#else+subExps (TupE es)        = es+#endif+subExps _                = []++-- | The expression in a clause body (the inline builder emits 'NormalB' for+-- leaves and a single-guard 'GuardedB' under fallthrough).+clauseBodyExp :: Body -> Exp+clauseBodyExp (NormalB e)             = e+clauseBodyExp (GuardedB ((_, e) : _)) = e+-- Total on the (unreached) empty-guard case: a var-free sentinel so a stray+-- input fails an assertion locally instead of aborting the whole spec run.+clauseBodyExp (GuardedB [])           = ConE '()++spec :: Spec+spec = describe "buildInlineParseClauses (pure inline parseRoute codegen)" $ do+    it "produces one clause for a single static leaf" $+        length (run (leaf "HomeR" [Static "home"] (methods ["GET"]))) `shouldBe` 1++    it "emits exactly one (committing) clause per parent, matching its prefix once" $ do+        -- 1.6 semantics: the parent contributes ONE top-level clause that+        -- matches the parent prefix, then cases over its children. It does not+        -- expand to one flat clause per descendant leaf (which would re-parse+        -- the prefix and let a child miss fall through to a sibling route).+        let tree = parent "AdminR" [Static "admin"]+                [ leaf "UsersR" [Static "users"] (methods ["GET"])+                , leaf "PostsR" [Static "posts"] (methods ["GET"])+                ]+        withOnlyClause (run tree) $ \c ->+            case caseMatches (clauseExp c) of+                Nothing -> expectationFailure "expected the parent clause body to be a case over children"+                -- two children + the committing Nothing fallback+                Just ms -> length ms `shouldBe` 3++    it "ends the parent's case with a Nothing fallback (commit-on-parent-prefix)" $ do+        -- This is the heart of the backwards-compat fix: once the parent prefix+        -- matches, a child miss must resolve to 'Nothing' (a 404 that agrees+        -- with dispatch), NOT fall through to a later top-level route.+        let tree = parent "AdminR" [Static "admin"]+                [ leaf "UsersR" [Static "users"] (methods ["GET"]) ]+        withOnlyClause (run tree) $ \c ->+            case caseMatches (clauseExp c) of+                Nothing -> expectationFailure "expected the parent clause body to be a case over children"+                Just ms -> case reverse ms of+                    (lastM : _) -> isNothingFallback lastM `shouldBe` True+                    []          -> expectationFailure "expected at least the Nothing fallback"++    it "commits at each level for deeply-nested parents (nested cases, each Nothing-terminated)" $ do+        let tree = parent "AR" [Static "a"]+                [ parent "BR" [Static "b"]+                    [ leaf "CR" [Static "c"] (methods ["GET"])+                    , leaf "DR" [Static "d"] (methods ["GET"])+                    ]+                ]+        -- One top-level clause for AR; its case has one child match (BR's+        -- committing clause-as-match) plus the Nothing fallback.+        withOnlyClause (run tree) $ \c ->+            case caseMatches (clauseExp c) of+                Nothing -> expectationFailure "expected AR's body to be a case"+                Just msA -> do+                    length msA `shouldBe` 2+                    isNothingFallback (last msA) `shouldBe` True+                    -- The non-fallback alternative is BR's committing match,+                    -- whose body is itself a case (over CR/DR) ending in Nothing.+                    case msA of+                        (Match _ (NormalB innerE) [] : _) ->+                            case caseMatches innerE of+                                Nothing  -> expectationFailure "expected BR's body to be a case"+                                Just msB -> do+                                    length msB `shouldBe` 3 -- CR, DR, Nothing+                                    isNothingFallback (last msB) `shouldBe` True+                        _ -> expectationFailure "unexpected shape for BR's match alternative"++    it "binds a dynamic piece with a fromPathPiece view pattern" $+        withOnlyClause (run (leaf "UserR" [Static "user", Dynamic (ConT ''Int)] (methods ["GET"]))) $ \c ->+            pprint c `shouldContain` "fromPathPiece"++    it "uses fromPathMultiPiece for a multipiece leaf" $+        withOnlyClause (run (leaf "FilesR" [Static "files"] (Methods (Just (ConT ''String)) ["GET"]))) $ \c ->+            pprint c `shouldContain` "fromPathMultiPiece"++    it "delegates a subsite leaf through parseRoute" $+        withOnlyClause (run (leaf "SubR" [Static "sub"] (Subsite (ConT (mkName "SubSite")) "getSub"))) $ \c ->+            pprint c `shouldContain` "parseRoute"++    it "prefixes accumulated parent pieces onto each descendant clause" $ do+        -- The parent's static piece must appear in the (single) child clause,+        -- alongside the child's own piece — that is what \"inline\" means.+        let tree = parent "OrgR" [Static "org", Dynamic (ConT ''Int)]+                [ leaf "TeamR" [Static "team"] (methods ["GET"]) ]+        withOnlyClause (run tree) $ \c -> do+            pprint c `shouldContain` "org"+            pprint c `shouldContain` "team"++    it "threads the parent's dynamic binder into the reconstructed route body" $ do+        -- A parent with a dynamic piece: its binder must be matched in the path+        -- pattern (via 'fromPathPiece') *and* fed back into the reconstructed+        -- route in the body. That threading — not merely that the pieces show+        -- up textually — is the property the inline arm has to preserve.+        let tree = parent "OrgR" [Static "org", Dynamic (ConT ''Int)]+                [ leaf "TeamR" [Static "team"] (methods ["GET"]) ]+        withOnlyClause (run tree) $ \(Clause pats body _) -> do+            let dynVars = concatMap boundDynVars pats+                used    = usedVars (clauseBodyExp body)+            -- Exactly one dynamic piece (the parent's, bound via fromPathPiece)+            -- and it is referenced in the reconstructed body — i.e. one 'True'.+            -- Empty dynVars gives @[] /= [True]@, so this never passes vacuously.+            map (`elem` used) dynVars `shouldBe` [True]
+ test/Route/InstanceProbeSpec.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Pins the answer to: /can 'isInstance' fail if the route datatype's+-- type parameters remain abstract?/ ('nestedInstanceExists'+-- saturates a resolved datatype with fresh, unannotated 'VarT's via+-- 'fullyApplyType' rather than ground types.)+--+-- The exercised contract:+--+--   * Saturation to the datatype's /own/ reified arity keeps the probed head+--     well-kinded, so the probe is a total query — \"could any instance+--     match\" — that returns 'True'\/'False' but never aborts the splice.+--   * It holds even when a parameter is higher-kinded (@(f :: Type -> Type)@):+--     the bare @VarT@ 'fullyApplyType' supplies has its kind inferred from the+--     datatype's declared kind, so the head is still well-kinded.+--   * The arity-0 case (no parameters) degenerates to probing the bare+--     constructor.+--+-- Each probe runs inside a compile-time splice wrapped in 'recover': if+-- 'isInstance' ever threw (the failure mode guarded against here), the+-- splice would fall through to the 'recover' handler, which 'error's, and the+-- expectation would fail loudly rather than silently.+module Route.InstanceProbeSpec (spec) where++import Test.Hspec+import Language.Haskell.TH (recover, isInstance, Type (ConT, AppT))+import Yesod.Routes.TH.Internal (nestedInstanceExists, resolveRouteCon)+import Route.InstanceProbeTypes+    ( Probe, HasInst, HasInst2, HasInstInt, NoInst, HK, HKInst, Mono+    , ProbePoly, PolyFull, PolyUnapplied, PolyPartial+    )++spec :: Spec+spec = describe "nestedInstanceExists / fullyApplyType abstract-parameter probe" $ do+    it "returns True for an arity-1 datatype that has an instance" $+        $(do+            rc <- resolveRouteCon "HasInst"+            recover [| error "isInstance crashed on HasInst" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` True++    it "returns True for an arity-2 datatype with an instance at abstract parameters" $+        $(do+            rc <- resolveRouteCon "HasInst2"+            recover [| error "isInstance crashed on HasInst2" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` True++    -- Whether probing the abstract head @HasInstInt a@ finds the concrete+    -- @instance Probe (HasInstInt Int)@ depends on the GHC version: GHC 9.0++    -- 'reifyInstances' returns unifiers (so a bare type variable in the query+    -- unifies with @Int@ and the probe reports 'True'), whereas GHC < 9.0 does+    -- not return the concrete-argument instance for a type-variable query head+    -- (so it reports 'False'). This concrete-argument shape never arises in real+    -- codegen — nested-discovery instances are always emitted at fully-abstract+    -- parameters (the 'HasInst' case above), which every supported GHC resolves+    -- identically — so this case only pins the observed 'reifyInstances'+    -- divergence, not a behaviour the codegen relies on.+#if __GLASGOW_HASKELL__ >= 900+    it "returns True when the only instance is at a concrete argument (a unifier counts as could-match)" $+        $(do+            rc <- resolveRouteCon "HasInstInt"+            recover [| error "isInstance crashed on HasInstInt" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` True+#else+    it "returns False when the only instance is at a concrete argument (GHC < 9.0 reifyInstances does not unify a type-variable query head)" $+        $(do+            rc <- resolveRouteCon "HasInstInt"+            recover [| error "isInstance crashed on HasInstInt" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` False+#endif++    it "returns False for an arity-1 datatype with no instance" $+        $(do+            rc <- resolveRouteCon "NoInst"+            recover [| error "isInstance crashed on NoInst" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` False++    it "does not crash on a higher-kinded (f :: Type -> Type) parameter with no instance (returns False)" $+        $(do+            rc <- resolveRouteCon "HK"+            recover [| error "isInstance crashed on HK" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` False++    it "does not crash on a higher-kinded parameter with an instance (returns True)" $+        $(do+            rc <- resolveRouteCon "HKInst"+            recover [| error "isInstance crashed on HKInst" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` True++    it "handles the zero-arity case (bare constructor head) with an instance" $+        $(do+            rc <- resolveRouteCon "Mono"+            recover [| error "isInstance crashed on Mono" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` True++    -- Poly-kinded class: lets us represent (and so probe) instances whose head+    -- is not fully applied — the shapes a 'Type'-kinded class rejects outright.+    it "ProbePoly: returns True for an instance at the fully-applied head" $+        $(do+            rc <- resolveRouteCon "PolyFull"+            recover [| error "isInstance crashed on PolyFull" |] $ do+                b <- nestedInstanceExists ''ProbePoly rc+                [| b |]) `shouldBe` True++    it "ProbePoly: returns False when the only instance is at the unapplied constructor (the arity-saturated probe head doesn't match it)" $+        $(do+            rc <- resolveRouteCon "PolyUnapplied"+            recover [| error "isInstance crashed on PolyUnapplied" |] $ do+                b <- nestedInstanceExists ''ProbePoly rc+                [| b |]) `shouldBe` False++    it "ProbePoly: returns False when the only instance is at a partially-applied head" $+        $(do+            rc <- resolveRouteCon "PolyPartial"+            recover [| error "isInstance crashed on PolyPartial" |] $ do+                b <- nestedInstanceExists ''ProbePoly rc+                [| b |]) `shouldBe` False++    -- Why 'nestedInstanceExists' must saturate to the datatype's *full* arity:+    -- the partial instance @ProbePoly (PolyPartial a)@ matches *any* one-argument+    -- application of @PolyPartial@. Probing one argument short — at @PolyPartial+    -- Int@ (kind Type -> Type) — therefore matches it, while the full-arity head+    -- @PolyPartial a b@ (kind Type, what the probe actually uses) does not. So a+    -- probe that stopped short would be spuriously fooled by a partial instance;+    -- saturating fully is what avoids that. These pin that matching boundary by+    -- calling 'isInstance' directly at hand-built heads.+    it "isInstance matches the partial instance one argument short (PolyPartial Int)" $+        $(do+            recover [| error "isInstance crashed on PolyPartial Int" |] $ do+                b <- isInstance ''ProbePoly [ConT ''PolyPartial `AppT` ConT ''Int]+                [| b |]) `shouldBe` True++    it "isInstance does not match the partial instance at the full application (PolyPartial Int Int)" $+        $(do+            recover [| error "isInstance crashed on PolyPartial Int Int" |] $ do+                b <- isInstance ''ProbePoly [ConT ''PolyPartial `AppT` ConT ''Int `AppT` ConT ''Int]+                [| b |]) `shouldBe` False++    it "isInstance does not match the unapplied-constructor instance once an argument is applied (PolyUnapplied Int)" $+        $(do+            recover [| error "isInstance crashed on PolyUnapplied Int" |] $ do+                b <- isInstance ''ProbePoly [ConT ''PolyUnapplied `AppT` ConT ''Int]+                [| b |]) `shouldBe` False
+ test/Route/InstanceProbeTypes.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}++-- | Datatypes and a stand-in probe class for "Route.InstanceProbeSpec", in+-- their own module so the spec's compile-time splices can 'reify' them — a+-- datatype defined in the same module as a top-level splice is not yet in the+-- type environment at a 'reify' (the same reason "Route.DeepArityTypes" is+-- separate).+--+-- 'Probe' stands in for any of the real nested-discovery classes+-- (@YesodDispatchNested@, @RenderRouteNested@, …) that 'nestedInstanceExists'+-- probes: those classes aren't visible to the pure @test-routes@ suite, but+-- 'nestedInstanceExists' only ever asks @isInstance klass [head]@, so any+-- single-parameter class with the right instance shape exercises the same+-- code path.+module Route.InstanceProbeTypes+    ( Probe+    , HasInst (..)+    , HasInst2 (..)+    , HasInstInt (..)+    , NoInst (..)+    , HK (..)+    , HKInst (..)+    , Mono (..)+      -- * Poly-kinded probe (under-applied instance heads)+    , ProbePoly+    , PolyFull (..)+    , PolyUnapplied (..)+    , PolyPartial (..)+    ) where++import Data.Kind (Type)++-- | A single-parameter probe class, standing in for the nested-discovery+-- classes 'nestedInstanceExists' checks against.+class Probe a++-- | Arity-1, kind-'Type' parameter, /with/ a @Probe@ instance — the probe must+-- answer 'True'. The instance is given at a fully abstract parameter, exactly+-- as our codegen emits per-route-datatype instances.+data HasInst a = HasInst+instance Probe (HasInst a)++-- | Arity-2: 'fullyApplyType' must saturate with /two/ fresh 'VarT's before+-- the head is well-kinded. With an instance at fully abstract parameters the+-- probe answers 'True'.+data HasInst2 a b = HasInst2+instance Probe (HasInst2 a b)++-- | Arity-1 whose only instance is at a /concrete/ argument. The probe asks+-- \"could any instance match\". On GHC 9.0+ 'reifyInstances' returns unifiers+-- (not just exact matches), so probing the abstract @HasInstInt a@ finds the+-- @Int@ instance and answers 'True'; on GHC < 9.0 'reifyInstances' does not+-- unify a bare type-variable query head against the concrete instance, so it+-- answers 'False'. (Real codegen never emits instances at concrete arguments,+-- so this divergence does not affect nested discovery; see the matching test in+-- "Route.InstanceProbeSpec".)+--+-- (Instances at an /under-applied/ constructor — the bare @instance Probe+-- HasInstInt@, or an arity-2 datatype applied to one argument like+-- @instance Probe (HasInst2 a)@ — can't be written against this 'Type'-kinded+-- 'Probe': a head of kind @Type -> Type@ is kind-rejected at its definition+-- site (GHC: \"Expecting one more argument to …; Expected a type, but … has+-- kind @* -> *@\"). To probe those shapes at all they must be made+-- representable by a /poly-kinded/ class; see 'ProbePoly' below.)+data HasInstInt a = HasInstInt+instance Probe (HasInstInt Int)++-- | Arity-1, kind-'Type' parameter, /without/ a @Probe@ instance — the probe+-- must answer 'False'.+data NoInst a = NoInst++-- | Arity-1 with a kind-annotated, non-'Type' parameter @(f :: Type -> Type)@+-- and /no/ instance. The point of this case: 'fullyApplyType' saturates @HK@+-- with a bare, unannotated @VarT@ whose kind GHC must infer from @HK@'s+-- declared kind. The probe must not crash and must report 'False'.+data HK (f :: Type -> Type) = HK++-- | As 'HK', but /with/ an instance given at an abstract higher-kinded+-- parameter. The probe must report 'True' without crashing.+data HKInst (f :: Type -> Type) = HKInst+instance Probe (HKInst f)++-- | Arity-0 (the zero type-parameter case): 'fullyApplyType' applies no+-- arguments, so the probed head is the bare constructor. With an instance the+-- probe answers 'True'.+data Mono = Mono+instance Probe Mono++-- | A /poly-kinded/ probe class. Unlike 'Probe' (kind @Type -> Constraint@),+-- @ProbePoly@ accepts a head of any kind, which makes the under-applied+-- instance shapes that 'Probe' rejects at their definition site representable —+-- so we can pin down what 'nestedInstanceExists' does when the only instance is+-- at such a head. The probe always saturates the datatype to its /own/ arity+-- (a kind-'Type' head; see 'fullyApplyType'), so these cases also confirm it+-- queries at the fully-applied head specifically.+class ProbePoly (a :: k)++-- | Poly-kinded class, instance at the /fully-applied/ head (kind 'Type').+-- Positive control: the probe saturates @PolyFull@ to @PolyFull a@ and matches.+data PolyFull a = PolyFull+instance ProbePoly (PolyFull a)++-- | Instance at the /unapplied/ arity-1 constructor (head kind @Type -> Type@),+-- representable only because 'ProbePoly' is poly-kinded. The probe saturates to+-- @PolyUnapplied a@ before querying, so the instance at the bare constructor is+-- a different head.+data PolyUnapplied a = PolyUnapplied+instance ProbePoly PolyUnapplied++-- | Instance at a /partially-applied/ arity-2 constructor (head kind+-- @Type -> Type@). As 'PolyUnapplied', the full-arity probe head+-- @PolyPartial a b@ is a different head from the partial instance @PolyPartial a@.+data PolyPartial a b = PolyPartial+instance ProbePoly (PolyPartial a)
+ test/Route/MissingFocusTargetSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Exercises the TH failure paths that fire when a 'setFocusOnNestedRoute'+-- target does not exist in the resource tree. Historically the 'ParseRoute'+-- and 'RouteAttrs' generators silently produced an always-'Nothing' \/+-- always-'mempty' nested instance for a bogus target, while the 'Dispatch' and+-- 'RenderRoute' generators correctly 'fail'ed. All four are now routed through+-- the shared 'findNestedRoute' lookup and 'fail' with the same message.+--+-- A 'Q' 'fail' raises its message through 'qReport' rather than carrying it in+-- the thrown value (so 'runQ' just reports @\"Q monad failure\"@), so — as in+-- "Route.DeepAritySpec" — we assert at compile time with 'recover': each+-- generator is run inside a splice against a nonexistent target and must take+-- its @fail@ path (driving 'recover' to its handler). The shared lookup that+-- produces the \"was not found in resources\" message is unit-tested directly+-- via 'findNestedRoute'.+module Route.MissingFocusTargetSpec (spec) where++import Test.Hspec+import Data.Maybe (isNothing)+import Language.Haskell.TH (recover)++import Yesod.Routes.TH.Types (resourceTreeName, TyArgs(NoTyArgs))+import Yesod.Routes.TH.ParseRoute (mkParseRouteInstanceFor)+import Yesod.Routes.TH.RouteAttrs (mkRouteAttrsInstanceFor)+import Yesod.Routes.TH.RenderRoute+    (mkRenderRouteInstanceOpts, defaultOpts, setFocusOnNestedRoute)+import Yesod.Routes.TH.Dispatch (mkDispatchInstance)+import Yesod.Routes.TH.Internal (findNestedRoute)+import Route.MissingFocusTargetTypes (sampleTree, bogusType, bogusName)++-- | 'True' iff the named generator 'fail'ed on the bogus focus target (i.e.+-- 'recover' fell through to its @True@ handler); 'False' if it wrongly produced+-- declarations. Each is forced at compile time so a regression to a silent+-- always-empty instance flips the corresponding boolean.++parseRouteFailed :: Bool+parseRouteFailed =+    $(recover [| True |] $ do+        _ <- mkParseRouteInstanceFor bogusName sampleTree+        [| False |])++routeAttrsFailed :: Bool+routeAttrsFailed =+    $(recover [| True |] $ do+        _ <- mkRouteAttrsInstanceFor [] bogusType bogusName sampleTree+        [| False |])++renderRouteFailed :: Bool+renderRouteFailed =+    $(recover [| True |] $ do+        _ <- mkRenderRouteInstanceOpts+                (setFocusOnNestedRoute bogusName defaultOpts)+                [] NoTyArgs bogusType sampleTree+        [| False |])++dispatchFailed :: Bool+dispatchFailed =+    $(recover [| True |] $ do+        _ <- mkDispatchInstance+                (setFocusOnNestedRoute bogusName defaultOpts)+                bogusType [] NoTyArgs pure sampleTree+        [| False |])++spec :: Spec+spec = describe "missing focus target" $ do+    describe "fails every nested generator (recover path)" $ do+        it "ParseRoute (mkParseRouteInstanceFor)" $+            parseRouteFailed `shouldBe` True+        it "RouteAttrs (mkRouteAttrsInstanceFor)" $+            routeAttrsFailed `shouldBe` True+        it "RenderRoute (mkRenderRouteInstanceOpts)" $+            renderRouteFailed `shouldBe` True+        it "Dispatch (mkDispatchInstance)" $+            dispatchFailed `shouldBe` True++    describe "shared lookup (findNestedRoute)" $ do+        it "returns Nothing for a target absent from the tree" $+            isNothing (findNestedRoute bogusName sampleTree)+                `shouldBe` True+        it "returns the subtree for a target present in the tree" $+            (fmap (map resourceTreeName . snd) (findNestedRoute "ParentR" sampleTree))+                `shouldBe` Just ["ChildR"]
+ test/Route/MissingFocusTargetTypes.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Shared fixtures for "Route.MissingFocusTargetSpec". The resource tree and+-- bogus type live here (a separate module) so that the spec can use them inside+-- top-level TH splices without tripping the GHC stage restriction.+module Route.MissingFocusTargetTypes+    ( sampleTree+    , bogusType+    , bogusName+    ) where++import Language.Haskell.TH.Syntax (Type(ConT), mkName)+import Yesod.Routes.TH.Types++-- A tiny tree with a single real nested parent ("ParentR"). The generators+-- under test are never handed that name; they get 'bogusName', which is absent.+sampleTree :: [ResourceTree Type]+sampleTree =+    [ ResourceParent "ParentR" True mempty [Static "parent"]+        [ ResourceLeaf $+            Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True+        ]+    ]++bogusName :: String+bogusName = "DefinitelyNotARealRouteR"++bogusType :: Type+bogusType = ConT (mkName bogusName)
+ test/Route/NestedParseClausesSpec.hs view
@@ -0,0 +1,61 @@+-- | Unit tests for 'generateParseRouteClause' run in 'PureQ' — the+-- monad-polymorphic (over 'Quote') nested @parseRouteNested@ clause generator.+-- Production runs it in 'Q' (hygienic 'newName'); here we pin its name supply to+-- a deterministic counter so its 'Clause' output — and the set of parent names+-- it requests a 'ParseRouteNested' instance for — can be asserted directly, with+-- no splicing or 'runQ'. This is the payoff of hoisting the @isInstance@ query+-- out of the generator (see 'generateParseRouteClause').+module Route.NestedParseClausesSpec (spec) where++import Test.Hspec+import Control.Monad.State.Strict (runStateT)+import qualified Data.Set as Set+import Data.Set (Set)+import Language.Haskell.TH+import Yesod.Routes.TH.Types+import Yesod.Routes.TH.RenderRoute (defaultOpts)+import Yesod.Routes.TH.ParseRoute (generateParseRouteClause)+import Route.PureQ (runPureQ)++-- | Run the nested clause generator in 'PureQ': deterministic fresh names, pure+-- output. Returns the clause plus the set of parent names it requested a+-- 'ParseRouteNested' instance for.+run :: Set String -> ResourceTree Type -> (Clause, Set String)+run existing t =+    runPureQ $+        runStateT (generateParseRouteClause existing defaultOpts t) mempty++leaf :: String -> [Piece Type] -> Dispatch Type -> ResourceTree Type+leaf name pieces d = ResourceLeaf (Resource name pieces d [] True)++methods :: [String] -> Dispatch Type+methods = Methods Nothing++parent :: String -> [Piece Type] -> [ResourceTree Type] -> ResourceTree Type+parent name pieces = ResourceParent name True mempty pieces++fooParent :: ResourceTree Type+fooParent =+    parent "FooR" [Static "foo"]+        [ leaf "BarR" [Static "bar"] (methods ["GET"]) ]++spec :: Spec+spec = describe "generateParseRouteClause (nested parseRoute codegen in PureQ)" $ do+    it "records a parent that has no nested instance yet" $+        snd (run mempty fooParent) `shouldBe` Set.singleton "FooR"++    it "does not record a parent that already has a nested instance (hoisted query)" $+        snd (run (Set.singleton "FooR") fooParent) `shouldBe` mempty++    it "delegates a parent clause through parseRouteNested" $+        pprint (fst (run mempty fooParent)) `shouldContain` "parseRouteNested"++    it "records nothing for a bare leaf" $+        snd (run mempty (leaf "BarR" [Static "bar"] (methods ["GET"]))) `shouldBe` mempty++    it "is reproducible: re-running the same tree yields an identical clause (names and all)" $+        -- The PureQ counter resets to 0 each run, so the deterministic binders+        -- make the whole Clause '=='. Under Q's 'newName' the uniques would+        -- differ between runs — this equality is exactly what going through the+        -- pure 'Quote' instance buys the tests.+        run mempty fooParent `shouldBe` run mempty fooParent
+ test/Route/PureQ.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | A pure 'Quote' instance for unit-testing the TH clause builders without+-- 'Q'. The builders are monad-polymorphic over 'Quote' (their only effect is+-- fresh-'Name' generation): production runs them in 'Q' for hygienic 'newName'+-- binders, while these tests run them in 'PureQ', where 'newName' is a+-- deterministic monotonic counter. That makes the generated '[Clause]' AST+-- fully determined and directly comparable — no splicing or 'runQ' needed.+--+-- The deterministic names use non-hygienic 'mkName', which is fine for+-- pure-inspection tests but would risk shadowing in real splices — hence+-- production stays on 'Q' and only the tests pin the builder's monad to 'PureQ'.+module Route.PureQ+    ( PureQ+    , runPureQ+    ) where++import Control.Monad.State.Strict (State, evalState, state)+import Language.Haskell.TH.Syntax (Name, mkName)+import Language.Haskell.TH.Syntax.Compat (Quote(..))++-- | A pure name supply: 'State' over a monotonic counter.+newtype PureQ a = PureQ (State Int a)+    deriving (Functor, Applicative, Monad)++-- | Run a 'PureQ' computation, starting the counter at @0@. Re-running the same+-- builder therefore yields an identical AST (binders and all).+runPureQ :: PureQ a -> a+runPureQ (PureQ s) = evalState s 0++-- | Each 'newName' yields a distinct 'mkName' from the counter, so the builder's+-- output is reproducible and comparable.+instance Quote PureQ where+    newName base = PureQ $ state $ \n -> (mkName (base ++ show n), n + 1)
+ test/Route/RenderRouteSpec.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns#-}++-- | Behavioural spec for @renderRouteNested@ on a deeply-nested route tree.+-- Pins the contract that rendering a nested leaf reconstructs the /entire/ path+-- from the site root (parent pieces and captures included), not just the leaf's+-- own fragment — the caller supplies the ancestor captures as a tuple.+module Route.RenderRouteSpec where++import Yesod.Core+import Test.Hspec++data App = App++mkYesodData "App" [parseRoutes|++/foo/#Int   FooR:+    /   FooIndexR+    /bar/#String    FooBarR:+        /   FooBarIndexR+        /baz    FooBarBazR:+            /new    FooBarBazNewR+            /delete/#String FooBarBazDeleteR+            /get/#String    FooBarBazGetR++    |]++spec :: Spec+spec = do+    describe "renderRouteNested" $ do+        it "renders the entire route, not just end fragment" $ do+            renderRouteNested (3, "hello") (FooBarBazGetR "asdf")+                `shouldBe`+                    (["foo", "3", "bar", "hello", "baz", "get", "asdf"], [])
+ test/Route/RouteAttrSpec.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE QuasiQuotes #-}++-- | Pure spec asserting that route attributes (@!x@) declared on a /nested+-- parent/ are captured in its flattened 'frParentDetails' (@pdAttrs@), not just+-- on leaves. Operates directly on the parsed 'ResourceTree' decision data — no+-- splicing or codegen — so it pins where in the flattened structure parent+-- attrs land.+module Route.RouteAttrSpec (spec) where++import Yesod.Core+import Test.Hspec+import Yesod.Routes.TH.Types+import Data.Set (Set)+import qualified Data.Set as Set++routeNoAttributes :: [ResourceTree String]+routeNoAttributes = [parseRoutes|+/one OneR:+  /two TwoR:+    /three ThreeR:+      /four FourR POST+  |]++routeWithAttributes :: [ResourceTree String]+routeWithAttributes = [parseRoutes|+/one OneR:+  /two TwoR !x !z:+    /three ThreeR !y:+      /four FourR POST+  |]++spec :: Spec+spec = do+    describe "route attrs present" $ do+        it "has no route attrs on parent" $ do+            let parentDetails = concat $ frParentDetails <$> flatten routeNoAttributes+            let attrs = (\detail -> (pdName detail, pdAttrs detail)) <$> parentDetails+            Set.fromList attrs+                `shouldBe`+                    Set.fromList +                        [ ("OneR", Set.empty)+                        , ("TwoR", Set.empty)+                        , ("ThreeR", Set.empty)+                        ]+        it "has route attrs on parent" $ do+            let parentDetails = concat $ frParentDetails <$> flatten routeWithAttributes+            let attrs = (\detail -> (pdName detail, pdAttrs detail)) <$> parentDetails+            Set.fromList attrs+                `shouldBe`+                    Set.fromList +                        [ ("OneR", Set.empty)+                        , ("TwoR", Set.fromList ["x", "z"])+                        , ("ThreeR", Set.singleton "y")+                        ]
+ test/Route/SubDispatchAritySpec.hs view
@@ -0,0 +1,78 @@+-- | Unit tests for 'checkNestedSubArity', the guard that gives+-- 'mkYesodSubDispatchInstance' an actionable error (instead of a cryptic kind+-- error) when a parameterized subsite is paired with unparameterized nested+-- route datatypes.+module Route.SubDispatchAritySpec (spec) where++import Test.Hspec+import Yesod.Routes.TH.Internal+    ( checkNestedSubArity+    , arityMismatchMessage+    , ArityCallSite(..)+    , ArityMismatch(..)+    , SubsiteName(..)+    , RouteName(..)+    , SubsiteArity(..)+    , RouteArity(..)+    )++-- | The newtype wrappers are positional noise in the tests; this names the+-- call the way the production caller does. 'Nothing' means the arities match;+-- 'Just' carries the rendered mismatch message (phrased for a 'SubsiteCall').+check :: String -> String -> Int -> Int -> Maybe String+check sub route subArgs routeArity =+    fmap (arityMismatchMessage SubsiteCall) $+        checkNestedSubArity+            (SubsiteName sub)+            (RouteName route)+            (SubsiteArity subArgs)+            (RouteArity routeArity)++spec :: Spec+spec = describe "checkNestedSubArity" $ do+    it "accepts a monomorphic subsite with an unparameterized nested datatype" $+        check "MySub" "NestedR" 0 0 `shouldBe` Nothing++    it "accepts a parameterized subsite whose nested datatype carries the param" $+        check "MySub" "NestedR" 1 1 `shouldBe` Nothing++    it "rejects when the nested datatype carries more params than the subsite" $+        -- Over-arity leaves the instance head partially applied (kind+        -- @Type -> ...@), so this must be rejected, not silently accepted.+        case check "MySub" "NestedR" 1 2 of+            Nothing -> expectationFailure "expected an arity mismatch"+            Just msg -> do+                msg `shouldContain` "`NestedR` has 2 type parameter(s)"+                msg `shouldContain` "the subsite `MySub` has 1"++    it "rejects a parameterized subsite with an unparameterized nested datatype" $+        check "MySub" "NestedR" 1 0 `shouldBe` Just+            (concat+                [ "mkYesodSubDispatchInstance: the nested route datatype "+                , "`NestedR` has 0 type parameter(s), but the subsite `MySub` "+                , "has 1. The subroute datatypes must carry exactly the "+                , "subsite's type parameter(s) \8212 generate the subsite's "+                , "routes with `mkYesodSubDataOpts (setParameterizedSubroute "+                , "True defaultOpts) ...` so a parameterized subsite gets "+                , "parameterized subroutes."+                ])++    it "names both types in the error message" $+        case check "MySub" "NestedR" 1 0 of+            Nothing -> expectationFailure "expected a mismatch"+            Just msg -> do+                msg `shouldContain` "MySub"+                msg `shouldContain` "NestedR"++    describe "arityMismatchMessage phrasing per call site" $ do+        let mismatch = ArityMismatch (SubsiteName "MySub") (RouteName "NestedR")+                                     (SubsiteArity 1) (RouteArity 0)+        it "names mkYesodSubDispatchInstance and calls it a subsite for a SubsiteCall" $ do+            let msg = arityMismatchMessage SubsiteCall mismatch+            msg `shouldContain` "mkYesodSubDispatchInstance"+            msg `shouldContain` "subsite"+        it "names mkYesod and calls it a site (not a subsite) for a TopLevelCall" $ do+            let msg = arityMismatchMessage TopLevelCall mismatch+            msg `shouldContain` "mkYesod:"+            msg `shouldNotContain` "subsite"+            msg `shouldContain` "site"
+ test/RouteSpec.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns#-}++-- | Entry point ('main') for the @test-routes@ suite — the pure-routing tests+-- that need no running site. Aggregates the @Route.*@ specs (fallthrough,+-- render, attrs, the pure decision/codegen specs, arity guards, focus-target+-- lookups, ...) and the @Hierarchy@ fixture, then adds inline RenderRoute /+-- route-parsing / overlap-checking / @parseRouteType@ checks below.++import Test.Hspec+import Test.HUnit ((@?=))+import Data.Text (Text)+import Yesod.Routes.Class hiding (Route)+import Yesod.Routes.Parse (parseTypeTree, TypeTree (..))+import Yesod.Core+import Yesod.Routes.Overlap (findOverlapNames)+import Yesod.Routes.TH hiding (Dispatch)+import Hierarchy+import qualified Data.Set as Set+import qualified Route.FallthroughSpec as FallthroughSpec+import qualified Route.RenderRouteSpec as RenderRouteSpec+import qualified YesodCoreTest.RenderRouteSpec as NestedRenderRouteSpec+import qualified Route.RouteAttrSpec as RouteAttrSpec+import qualified Route.DiscoveryModeSpec as DiscoveryModeSpec+import qualified Route.SubDispatchAritySpec as SubDispatchAritySpec+import qualified Route.DeepAritySpec as DeepAritySpec+import qualified Route.InstanceProbeSpec as InstanceProbeSpec+import qualified Route.InlineParseClausesSpec as InlineParseClausesSpec+import qualified Route.NestedParseClausesSpec as NestedParseClausesSpec+import qualified Route.FocusLeafConsSpec as FocusLeafConsSpec+import qualified Route.MissingFocusTargetSpec as MissingFocusTargetSpec+import qualified Data.Text as Text++data MyApp = MyApp++data MySub = MySub+instance RenderRoute MySub where+    data+        Route+        MySub = MySubRoute ([Text], [(Text, Text)])+        deriving (Show, Eq, Read)+    renderRoute (MySubRoute x) = x+instance ParseRoute MySub where+    parseRoute = Just . MySubRoute++getMySub :: MyApp -> MySub+getMySub MyApp = MySub++data MySubParam = MySubParam Int+instance RenderRoute MySubParam where+    data+        Route+        MySubParam = ParamRoute Char+        deriving (Show, Eq, Read)+    renderRoute (ParamRoute x) = ([Text.singleton x], [])+instance ParseRoute MySubParam where+    parseRoute ([Text.unpack -> [x]], _) = Just $ ParamRoute x+    parseRoute _ = Nothing++getMySubParam :: MyApp -> Int -> MySubParam+getMySubParam _ = MySubParam++do+    texts <- pure "[Text]"+    let resLeaves = map ResourceLeaf+            [ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"] True+            , Resource "BlogPostR" [Static "blog", Dynamic "Text"] (Methods Nothing ["GET", "POST"]) [] True+            , Resource "WikiR" [Static "wiki"] (Methods (Just texts) []) [] True+            , Resource "SubsiteR" [Static "subsite"] (Subsite "MySub" "getMySub") [] True+            , Resource "SubparamR" [Static "subparam", Dynamic "Int"] (Subsite "MySubParam" "getMySubParam") [] True+            ]+        resParent = ResourceParent+            "ParentR"+            True+            mempty+            [ Static "foo"+            , Dynamic "Text"+            ]+            [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True+            ]+        ress = resParent : resLeaves+    mkYesod "MyApp" ress++instance YesodSubDispatch MySub MyApp where+    yesodSubDispatch _yre = undefined++instance YesodSubDispatch MySubParam MyApp where+    yesodSubDispatch _yre = undefined++instance Yesod MyApp where+    messageLoggerSource = mempty++main :: IO ()+main = hspec $ do+    describe "Route.FallthroughSpec" FallthroughSpec.spec+    describe "Route.RenderRouteSpec" RenderRouteSpec.spec+    describe "YesodCoreTest.RenderRouteSpec" NestedRenderRouteSpec.spec+    describe "Route.RouteAttrSpec" RouteAttrSpec.spec+    describe "Route.DiscoveryModeSpec" DiscoveryModeSpec.spec+    describe "Route.SubDispatchAritySpec" SubDispatchAritySpec.spec+    describe "Route.DeepAritySpec" DeepAritySpec.spec+    describe "Route.InstanceProbeSpec" InstanceProbeSpec.spec+    describe "Route.InlineParseClausesSpec" InlineParseClausesSpec.spec+    describe "Route.NestedParseClausesSpec" NestedParseClausesSpec.spec+    describe "Route.FocusLeafConsSpec" FocusLeafConsSpec.spec+    describe "Route.MissingFocusTargetSpec" MissingFocusTargetSpec.spec+    describe "RenderRoute instance" $ do+        it "renders root correctly" $ renderRoute RootR @?= ([], [])+        it "renders blog post correctly" $ renderRoute (BlogPostR $ Text.pack "foo") @?= (map Text.pack ["blog", "foo"], [])+        it "renders wiki correctly" $ renderRoute (WikiR $ map Text.pack ["foo", "bar"]) @?= (map Text.pack ["wiki", "foo", "bar"], [])+        it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map Text.pack ["foo", "bar"], [(Text.pack "baz", Text.pack "bin")]))+            @?= (map Text.pack ["subsite", "foo", "bar"], [(Text.pack "baz", Text.pack "bin")])+        it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c')+            @?= (map Text.pack ["subparam", "6", "c"], [])+++    describe "route parsing" $ do+        it "subsites work" $ do+            parseRoute ([Text.pack "subsite", Text.pack "foo"], [(Text.pack "bar", Text.pack "baz")]) @?=+                Just (SubsiteR $ MySubRoute ([Text.pack "foo"], [(Text.pack "bar", Text.pack "baz")]))++    describe "routing table parsing" $ do+        it "recognizes trailing backslashes as line continuation directives" $ do+            let routes :: [ResourceTree String]+                routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations.yesodroutes")+            length routes @?= 3++    describe "overlap checking" $ do+        it "catches overlapping statics" $ do+            let routes :: [ResourceTree String]+                routes = [parseRoutesNoCheck|+/foo Foo1+/foo Foo2+|]+            findOverlapNames routes @?= [("Foo1", "Foo2")]+        it "catches overlapping dynamics" $ do+            let routes :: [ResourceTree String]+                routes = [parseRoutesNoCheck|+/#Int Foo1+/#String Foo2+|]+            findOverlapNames routes @?= [("Foo1", "Foo2")]+        it "catches overlapping statics and dynamics" $ do+            let routes :: [ResourceTree String]+                routes = [parseRoutesNoCheck|+/foo Foo1+/#String Foo2+|]+            findOverlapNames routes @?= [("Foo1", "Foo2")]+        it "catches overlapping multi" $ do+            let routes :: [ResourceTree String]+                routes = [parseRoutesNoCheck|+/foo Foo1+/##*Strings Foo2+|]+            findOverlapNames routes @?= [("Foo1", "Foo2")]+        it "catches overlapping subsite" $ do+            let routes :: [ResourceTree String]+                routes = [parseRoutesNoCheck|+/foo Foo1+/foo Foo2 Subsite getSubsite+|]+            findOverlapNames routes @?= [("Foo1", "Foo2")]+        it "no false positives" $ do+            let routes :: [ResourceTree String]+                routes = [parseRoutesNoCheck|+/foo Foo1+/bar/#String Foo2+|]+            findOverlapNames routes @?= []+        it "obeys ignore rules" $ do+            let routes :: [ResourceTree String]+                routes = [parseRoutesNoCheck|+/foo Foo1+/#!String Foo2+/!foo Foo3+|]+            findOverlapNames routes @?= []+        it "obeys multipiece ignore rules #779" $ do+            let routes :: [ResourceTree String]+                routes = [parseRoutesNoCheck|+/foo Foo1+/+![String] Foo2+|]+            findOverlapNames routes @?= []+        it "ignore rules for entire route #779" $ do+            let routes :: [ResourceTree String]+                routes = [parseRoutesNoCheck|+/foo Foo1+!/+[String] Foo2+!/#String Foo3+!/foo Foo4+|]+            findOverlapNames routes @?= []+        it "ignore rules for hierarchy" $ do+            let routes :: [ResourceTree String]+                routes = [parseRoutesNoCheck|+/+[String] Foo1+!/foo Foo2:+    /foo Foo3+/foo Foo4:+    /!#foo Foo5+|]+            findOverlapNames routes @?= []+        it "proper boolean logic" $ do+            let routes = [parseRoutesNoCheck|+/foo/bar Foo1+/foo/baz Foo2+/bar/baz Foo3+|]+            findOverlapNames routes @?= []+    describe "routeAttrs" $ do+        it "works" $ do+            routeAttrs RootR @?= Set.fromList [Text.pack "foo", Text.pack "bar"]+        it "hierarchy" $ do+            routeAttrs (ParentR (Text.pack "ignored") ChildR) @?= Set.singleton (Text.pack "child")+    hierarchy+    describe "parseRouteType" $ do+        let success s t = it s $ parseTypeTree s @?= Just t+            failure s = it s $ parseTypeTree s @?= Nothing+        success "Int" $ TTTerm "Int"+        success "(Int)" $ TTTerm "Int"+        failure "(Int"+        failure "(Int))"+        failure "[Int"+        failure "[Int]]"+        success "[Int]" $ TTList $ TTTerm "Int"+        success "Foo-Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar")+        success "Foo-Bar-Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz"+        success "Foo Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar")+        success "Foo Bar Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz"++getRootR :: HandlerFor site Text+getRootR = pure $ Text.pack "this is the root"++getBlogPostR :: Text -> HandlerFor site String+getBlogPostR t = pure $ "some blog post: " ++ Text.unpack t++postBlogPostR :: Text -> HandlerFor site Text+postBlogPostR t = pure $ Text.pack $ "POST some blog post: " ++ Text.unpack t++handleWikiR :: [Text] -> HandlerFor site String+handleWikiR ts = pure $ "the wiki: " ++ show ts++getChildR :: Text -> HandlerFor site Text+getChildR = pure
test/YesodCoreTest.hs view
@@ -1,33 +1,117 @@-module YesodCoreTest (specs) where +{-# LANGUAGE CPP #-} +module YesodCoreTest (specs) where+ import YesodCoreTest.CleanPath import YesodCoreTest.Exceptions import YesodCoreTest.Widget import YesodCoreTest.Media+import YesodCoreTest.Meta import YesodCoreTest.Links+import YesodCoreTest.Header import YesodCoreTest.NoOverloadedStrings+import YesodCoreTest.SubSub+import YesodCoreTest.SplitSubsite.Runtime (splitSubsiteSpec)+import YesodCoreTest.ParameterizedSubData ()+import YesodCoreTest.ParamSubsite.Data ()+import YesodCoreTest.ParameterizedSubDispatch ()+import qualified YesodCoreTest.ParameterizedSubDispatchRuntime as ParameterizedSubDispatchRuntime+import qualified YesodCoreTest.ParamSubsite.InstanceRuntime as ParamSubsiteInstanceRuntime+import qualified YesodCoreTest.ParamSubsite.SplitRuntime as ParamSubsiteSplitRuntime+import qualified YesodCoreTest.ParamDefaultSplit.Runtime as ParamDefaultSplitRuntime+import qualified YesodCoreTest.ParamTopLevelRuntime as ParamTopLevelRuntime+import qualified YesodCoreTest.ParamFocusSplit.Runtime as ParamFocusSplit+import qualified YesodCoreTest.ParamNoExplicitArgs as ParamNoExplicitArgs+import qualified YesodCoreTest.ParamFallthroughRuntime as ParamFallthroughRuntime+import qualified YesodCoreTest.ParamNoFallthroughRuntime as ParamNoFallthroughRuntime+import qualified YesodCoreTest.ParamNestedNoFallthroughRuntime as ParamNestedNoFallthroughRuntime+import qualified YesodCoreTest.FallthroughMatrix.Runtime as FallthroughMatrixRuntime+import qualified YesodCoreTest.MultiPieceNestedRuntime as MultiPieceNestedRuntime+import qualified YesodCoreTest.ZeroPieceShadowRuntime as ZeroPieceShadowRuntime+import qualified YesodCoreTest.BangSeparatorRuntime as BangSeparatorRuntime+import qualified YesodCoreTest.SubsiteFallthrough.Runtime as SubsiteFallthrough+import qualified YesodCoreTest.SubsiteOptsFallthrough.Runtime as SubsiteOptsFallthrough import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling import YesodCoreTest.Cache+import YesodCoreTest.ParameterizedSite+import YesodCoreTest.Breadcrumb import qualified YesodCoreTest.WaiSubsite as WaiSubsite import qualified YesodCoreTest.Redirect as Redirect+import qualified YesodCoreTest.JsAttributes as JsAttributes import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize+import qualified YesodCoreTest.Json as Json+import qualified YesodCoreTest.Content as Content+import qualified YesodCoreTest.NestedDispatch.Runtime as NestedDispatch+import qualified YesodCoreTest.FallthroughDispatch.Runtime as FallthroughDispatch +-- Skip on Windows, see https://github.com/yesodweb/yesod/issues/1523#issuecomment-398278450+#ifndef WINDOWS+import qualified YesodCoreTest.RawResponse as RawResponse+#endif++import qualified YesodCoreTest.Streaming as Streaming+import qualified YesodCoreTest.Reps as Reps+import qualified YesodCoreTest.Auth as Auth+import qualified YesodCoreTest.LiteApp as LiteApp+import qualified YesodCoreTest.Ssl as Ssl+import qualified YesodCoreTest.Csrf as Csrf+ import Test.Hspec  specs :: Spec specs = do+      headerTest       cleanPathTest       exceptionsTest       widgetTest       mediaTest       linksTest       noOverloadedTest+      subSubTest+      splitSubsiteSpec       internalRequestTest       errorHandlingTest       cacheTest+      parameterizedSiteTest       WaiSubsite.specs       Redirect.specs+      JsAttributes.specs       JsLoader.specs       RequestBodySize.specs+      Json.specs+#ifndef WINDOWS+      RawResponse.specs+#endif+      Streaming.specs+      Reps.specs+      Auth.specs+      LiteApp.specs+      Ssl.unsecSpec+      Ssl.sslOnlySpec+      Ssl.sameSiteSpec+      Csrf.csrfSpec+      breadcrumbTest+      metaTest+      Content.specs+      describe "NestedDispatch" $ do+          NestedDispatch.specs+      ParameterizedSubDispatchRuntime.specs+      ParamSubsiteInstanceRuntime.specs+      ParamSubsiteSplitRuntime.specs+      ParamDefaultSplitRuntime.specs+      ParamTopLevelRuntime.specs+      ParamFocusSplit.specs+      ParamNoExplicitArgs.specs+      ParamFallthroughRuntime.specs+      ParamNoFallthroughRuntime.specs+      ParamNestedNoFallthroughRuntime.specs+      FallthroughMatrixRuntime.specs+      MultiPieceNestedRuntime.specs+      ZeroPieceShadowRuntime.specs+      BangSeparatorRuntime.specs+      SubsiteFallthrough.specs+      SubsiteOptsFallthrough.specs+      describe "FallthroughDispatch" $ do+          FallthroughDispatch.spec
+ test/YesodCoreTest/Auth.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module YesodCoreTest.Auth+    ( specs+    , Widget+    , resourcesApp+    ) where++import Yesod.Core+import Test.Hspec+import Network.Wai.Test+import Network.Wai+import qualified Data.ByteString.Char8 as S8+import qualified Data.Text as T+import Data.List (isSuffixOf)+import qualified Network.HTTP.Types as H++data App = App++mkYesod "App" [parseRoutes|+/no-auth NoAuthR+/needs-login-json NeedsLoginJsonR+/needs-login-html NeedsLoginHtmlR+/read-only ReadOnlyR+/forbidden ForbiddenR+|]++instance Yesod App where+    isAuthorized NoAuthR _ = return Authorized+    isAuthorized NeedsLoginJsonR _ = return AuthenticationRequired+    isAuthorized NeedsLoginHtmlR _ = return AuthenticationRequired+    isAuthorized ReadOnlyR False = return Authorized+    isAuthorized ReadOnlyR True = return $ Unauthorized "Read only"+    isAuthorized ForbiddenR _ = return $ Unauthorized "Forbidden"+    authRoute _ = Just NoAuthR++handleNoAuthR, handleReadOnlyR, handleForbiddenR :: Handler ()+handleNoAuthR     = return ()+handleReadOnlyR   = return ()+handleForbiddenR  = return ()++handleNeedsLoginJsonR :: Handler RepJson+handleNeedsLoginJsonR = return $ repJson $ object []+handleNeedsLoginHtmlR :: Handler Html+handleNeedsLoginHtmlR = return ""++test :: String -- ^ method+     -> String -- ^ path+     -> (SResponse -> Session ())+     -> Spec+test method path f = it (method ++ " " ++ path) $ do+    app <- toWaiApp App+    flip runSession app $ do+        sres <- request defaultRequest+            { requestMethod = S8.pack method+            , pathInfo = [T.pack path]+            , requestHeaders =+                if not $ isSuffixOf "json" path then [] else+                  [("Accept", S8.pack "application/json")]+            , httpVersion = H.http11+            }+        f sres++specs :: Spec+specs = describe "Auth" $ do+    test "GET" "no-auth" $ \sres -> assertStatus 200 sres+    test "POST" "no-auth" $ \sres -> assertStatus 200 sres+    test "GET" "needs-login-html" $ \sres -> assertStatus 303 sres+    test "POST" "needs-login-html" $ \sres -> assertStatus 303 sres+    test "GET" "needs-login-json" $ \sres -> assertStatus 401 sres+    test "POST" "needs-login-json" $ \sres -> assertStatus 401 sres+    test "GET" "read-only" $ \sres -> assertStatus 200 sres+    test "POST" "read-only" $ \sres -> assertStatus 403 sres+    test "GET" "forbidden" $ \sres -> assertStatus 403 sres+    test "POST" "forbidden" $ \sres -> assertStatus 403 sres
+ test/YesodCoreTest/BangSeparatorRuntime.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | T2: a @!@-separated dynamic route (@\/!#Int@) is only ever exercised by the+-- render/parse specs (in the @test-routes@ suite's pure-routing @Hierarchy@+-- fixture). The @!@ flips /compile-time/ overlap checking only, so at runtime+-- @\/!#Int@ dispatches exactly like @\/#Int@. This pins that equivalence with a+-- real WAI round-trip.+module YesodCoreTest.BangSeparatorRuntime+    ( specs+    ) where++import Test.Hspec+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Yesod.Core++import YesodCoreTest.RuntimeHarness (assertGet)++data BangApp = BangApp++mkYesod "BangApp" [parseRoutes|+/!#Int BackwardsR GET+/plain/#Int PlainR GET+|]++instance Yesod BangApp where+    messageLoggerSource = mempty++getBackwardsR :: Int -> HandlerFor BangApp Text+getBackwardsR i = pure (toPathPiece i <> ":backwards")++getPlainR :: Int -> HandlerFor BangApp Text+getPlainR i = pure (toPathPiece i <> ":plain")++req :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO ()+req = assertGet BangApp++specs :: Spec+specs = describe "!-separator dynamic route dispatch (/!#Int)" $ do+    it "dispatches BackwardsR on a numeric piece, like a plain /#Int" $+        req 200 ["5"] (Just "5:backwards")+    it "still 404s a non-numeric piece (the # parser is unchanged by !)" $+        req 404 ["notanint"] Nothing+    it "dispatches the plain /#Int sibling for contrast" $+        req 200 ["plain", "7"] (Just "7:plain")
+ test/YesodCoreTest/Breadcrumb.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module YesodCoreTest.Breadcrumb+  ( breadcrumbTest,+  )+where++import Data.Text (Text)+import Network.Wai+import Network.Wai.Test+import Test.Hspec+import Yesod.Core++data A = A++mkYesod+  "A"+  [parseRoutes|+/    RootR GET+/loop LoopR GET+|]++instance Yesod A++instance YesodBreadcrumbs A where+  breadcrumb r = case r of+    RootR -> pure ("Root", Nothing)+    LoopR -> pure ("Loop", Just LoopR) -- Purposefully a loop++getRootR :: Handler Text+getRootR = fst <$> breadcrumbs++getLoopR :: Handler Text+getLoopR = fst <$> breadcrumbs++breadcrumbTest :: Spec+breadcrumbTest =+  describe "Test.Breadcrumb" $ do+    it "can fetch the root which contains breadcrumbs" $+      runner $ do+        res <- request defaultRequest+        assertStatus 200 res+    it "gets a 500 for a route with a looping breadcrumb" $+      runner $ do+        res <- request defaultRequest {pathInfo = ["loop"]}+        assertStatus 500 res++runner :: Session () -> IO ()+runner f = toWaiApp A >>= runSession f
test/YesodCoreTest/Cache.hs view
@@ -1,48 +1,123 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}-module YesodCoreTest.Cache (cacheTest, Widget) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} +module YesodCoreTest.Cache+    ( cacheTest+    , Widget+    , resourcesC+    ) where+ import Test.Hspec  import Network.Wai import Network.Wai.Test  import Yesod.Core+import UnliftIO.IORef+import Data.Typeable (Typeable)+import qualified Data.ByteString.Lazy.Char8 as L8  data C = C -key :: CacheKey Int-key = $(mkCacheKey)+newtype V1 = V1 Int -key2 :: CacheKey Int-key2 = $(mkCacheKey)+newtype V2 = V2 Int -mkYesod "C" [parseRoutes|/ RootR GET|]+mkYesod "C" [parseRoutes|+/    RootR GET+/key KeyR GET+/nested NestedR GET+/nested-key NestedKeyR GET+|] -instance Yesod C+instance Yesod C where+    errorHandler e = liftIO (print e) >> defaultErrorHandler e -getRootR :: Handler ()+getRootR :: Handler RepPlain getRootR = do-    Nothing <- cacheLookup key-    cacheInsert key 5-    Just 5 <- cacheLookup key-    cacheInsert key 7-    Just 7 <- cacheLookup key-    Nothing <- cacheLookup key2-    cacheDelete key-    Nothing <- cacheLookup key-    return ()+    ref <- newIORef 0+    V1 v1a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1)+    V1 v1b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) +    V2 v2a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)+    V2 v2b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)++    cacheBySet "3" (V2 3)+    V2 v3a <- cacheByGet "3" >>= \x ->+      case x of+        Just y -> return y+        Nothing -> error "must be Just"+    V2 v3b <- cachedBy "3" $ (pure $ V2 4)++    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b]++getKeyR :: Handler RepPlain+getKeyR = do+    ref <- newIORef 0+    V1 v1a <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1)+    V1 v1b <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1)++    V2 v2a <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)+    V2 v2b <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)++    V2 v3a <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)+    V2 v3b <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)+++    cacheBySet "4" (V2 4)+    V2 v4a <- cacheByGet "4" >>= \x ->+      case x of+        Just y -> return y+        Nothing -> error "must be Just"+    V2 v4b <- cachedBy "4" $ (pure $ V2 5)++    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b, v4a, v4b]++getNestedR :: Handler RepPlain+getNestedR = getNested cached++getNestedKeyR :: Handler RepPlain+getNestedKeyR = getNested $ cachedBy "3"++-- | Issue #1266+getNested ::  (forall a. Typeable a => (Handler a -> Handler a)) -> Handler RepPlain+getNested cacheMethod = do+    ref <- newIORef 0+    let getV2 = atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)+    V1 _ <- cacheMethod $ do+      V2 val <- cacheMethod $ getV2+      return $ V1 val+    V2 v2 <- cacheMethod $ getV2++    return $ RepPlain $ toContent $ show v2+ cacheTest :: Spec cacheTest =   describe "Test.Cache" $ do-      it "works" works+    it "cached" $ runner $ do+      res <- request defaultRequest+      assertStatus 200 res+      assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res +    it "cachedBy" $ runner $ do+      res <- request defaultRequest { pathInfo = ["key"] }+      assertStatus 200 res+      assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3, 4, 4 :: Int]) res++    it "nested cached" $ runner $ do+      res <- request defaultRequest { pathInfo = ["nested"] }+      assertStatus 200 res+      assertBody (L8.pack $ show (1 :: Int)) res++    it "nested cachedBy" $ runner $ do+      res <- request defaultRequest { pathInfo = ["nested-key"] }+      assertStatus 200 res+      assertBody (L8.pack $ show (1 :: Int)) res+ runner :: Session () -> IO () runner f = toWaiApp C >>= runSession f--works :: IO ()-works = runner $ do-    res <- request defaultRequest { pathInfo = [] }-    assertStatus 200 res
test/YesodCoreTest/CleanPath.hs view
@@ -1,11 +1,20 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}-module YesodCoreTest.CleanPath (cleanPathTest, Widget) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} +module YesodCoreTest.CleanPath+    ( cleanPathTest+    , Widget+    , resourcesY+    ) where+ import Test.Hspec -import Yesod.Core hiding (Request)+import Yesod.Core  import Network.Wai import Network.Wai.Test@@ -16,8 +25,7 @@ import qualified Data.Text.Encoding as TE import Control.Arrow ((***)) import Network.HTTP.Types (encodePath)-import Data.Monoid (mappend)-import Blaze.ByteString.Builder.Char.Utf8 (fromText)+import Data.Text.Encoding (encodeUtf8Builder)  data Subsite = Subsite @@ -28,12 +36,14 @@     data Route Subsite = SubsiteRoute [TS.Text]         deriving (Eq, Show, Read)     renderRoute (SubsiteRoute x) = (x, [])+instance ParseRoute Subsite where+    parseRoute (x, _) = Just $ SubsiteRoute x -instance YesodDispatch Subsite master where-    yesodDispatch _ _ _ _ _ _ _ pieces _ _ = return $ responseLBS+instance YesodSubDispatch Subsite master where+    yesodSubDispatch _ req f = f $ responseLBS         status200         [ ("Content-Type", "SUBSITE")-        ] $ L8.pack $ show pieces+        ] $ L8.pack $ show (pathInfo req)  data Y = Y mkYesod "Y" [parseRoutes|@@ -57,7 +67,7 @@         corrected = filter (not . TS.null) s      joinPath Y ar pieces' qs' =-        fromText ar `mappend` encodePath pieces qs+        encodeUtf8Builder ar `mappend` encodePath pieces qs       where         pieces = if null pieces' then [""] else pieces'         qs = map (TE.encodeUtf8 *** go) qs'@@ -84,6 +94,11 @@       it "/foo/something" fooSomething       it "subsite dispatch" subsiteDispatch       it "redirect with query string" redQueryString+      it "parsing" $ do+        parseRoute (["foo"], []) `shouldBe` Just FooR+        parseRoute (["foo", "bar"], []) `shouldBe` Just (FooStringR "bar")+        parseRoute (["subsite", "some", "path"], []) `shouldBe` Just (SubsiteR $ SubsiteRoute ["some", "path"])+        parseRoute (["ignore", "me"], []) `shouldBe` (Nothing :: Maybe (Route Y))  runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f
+ test/YesodCoreTest/Content.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+module YesodCoreTest.Content (specs) where++import Test.Hspec++import Yesod.Core+import Yesod.Core.Types (TypedContent, typedContentToSnippet)+import Data.Text (Text, pack)+import Data.Text.Encoding (encodeUtf8)+import Data.ByteString (ByteString)++import qualified Data.Encoding as Enc+import qualified Data.Encoding.GB18030 as Enc+import qualified Data.Encoding.CP1251 as Enc+import qualified Data.Encoding.ShiftJIS as Enc+import qualified Data.Encoding.CP932 as Enc++fakeContent :: (String -> ByteString) -> String -> String -> TypedContent+fakeContent encode contentTypeString contentString =+  TypedContent+  (encode contentTypeString)+  (toContent $ encode contentString)++fakeUtf8Content :: String -> String -> TypedContent+fakeUtf8Content = fakeContent (encodeUtf8 . pack)++fakeGB18030Content :: String -> String -> TypedContent+fakeGB18030Content = fakeContent $ Enc.encodeStrictByteString Enc.GB18030++fakeCP1251Content :: String -> String -> TypedContent+fakeCP1251Content = fakeContent $ Enc.encodeStrictByteString Enc.CP1251++fakeShiftJISContent :: String -> String -> TypedContent+fakeShiftJISContent = fakeContent $ Enc.encodeStrictByteString Enc.ShiftJIS++fakeCP932Content :: String -> String -> TypedContent+fakeCP932Content = fakeContent $ Enc.encodeStrictByteString Enc.CP932++specs :: Spec+specs = describe "typedContentToSnippet" $ do+    it "does not serialize content that is apparently binary data" $ do+      let content = fakeUtf8Content "application/octet-stream" "fake"+      (typedContentToSnippet content 100) `shouldBe` Nothing++    it "serializes UTF-8 encoded JSON" $ do+      let content = fakeUtf8Content "application/json; charset=utf-8" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes text with no specified encoding" $ do+      let content = fakeUtf8Content "text/css" "fake"+      (typedContentToSnippet content 100) `shouldBe` (Just "fake")++    it "serializes RSS with no specified encoding" $ do+      let content = fakeUtf8Content "application/rss" "fake"+      (typedContentToSnippet content 100) `shouldBe` (Just "fake")++    it "serializes Atom feeds with no specified encoding" $ do+      let content = fakeUtf8Content "application/atom" "fake"+      (typedContentToSnippet content 100) `shouldBe` (Just "fake")++    it "truncates long snippets" $ do+      let content = fakeUtf8Content "application/json; charset=utf-8" "[1,2,3]"+      (typedContentToSnippet content 2) `shouldBe` (Just "[1...+ 5")++    it "serializes GB18030 text" $ do+      let content = fakeGB18030Content "application/json; charset=GB18030" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes CP1251 text" $ do+      let content = fakeCP1251Content "application/json; charset=windows-1251" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes ShiftJIS text" $ do+      let content = fakeShiftJISContent "application/json; charset=Shift_JIS" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes CP932 text" $ do+      let content = fakeCP932Content "application/json; charset=Windows-31J" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")
+ test/YesodCoreTest/Csrf.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module YesodCoreTest.Csrf (csrfSpec, Widget, resourcesApp) where++import Yesod.Core++import Test.Hspec+import Network.Wai+import Network.Wai.Test+import Web.Cookie+import qualified Data.Map as Map+import Data.ByteString.Lazy (fromStrict)++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET POST+|]++instance Yesod App where+    yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware++getHomeR :: Handler Html+getHomeR = defaultLayout+    [whamlet|+        <p>+            Welcome to my test application.+    |]++postHomeR :: Handler Html+postHomeR = defaultLayout+    [whamlet|+        <p>+            Welcome to my test application.+    |]++runner :: Session () -> IO ()+runner f = toWaiApp App >>= runSession f++csrfSpec :: Spec+csrfSpec = describe "A Yesod application with the defaultCsrfMiddleware" $ do+    it "serves a includes a cookie in a GET request" $ runner $ do+        res <- request defaultRequest+        assertStatus 200 res+        assertClientCookieExists "Should have an XSRF-TOKEN cookie" defaultCsrfCookieName++    it "uses / as the path of the cookie" $ runner $ do -- https://github.com/yesodweb/yesod/issues/1247+        res <- request defaultRequest+        assertStatus 200 res+        cookiePath <- fmap setCookiePath requireCsrfCookie+        liftIO $ cookiePath `shouldBe` Just "/"++    it "200s write requests with the correct CSRF header, but no param" $ runner $ do+        getRes <- request defaultRequest+        assertStatus 200 getRes+        csrfValue <- fmap setCookieValue requireCsrfCookie+        postRes <- request (defaultRequest { requestMethod = "POST", requestHeaders = [(defaultCsrfHeaderName, csrfValue)] })+        assertStatus 200 postRes++    it "200s write requests with the correct CSRF param, but no header" $ runner $ do+        getRes <- request defaultRequest+        assertStatus 200 getRes+        csrfValue <- fmap setCookieValue requireCsrfCookie++        let body = "_token=" <> csrfValue+        postRes <- srequest $ SRequest (defaultRequest { requestMethod = "POST", requestHeaders = [("Content-Type","application/x-www-form-urlencoded")] }) (fromStrict body)+        assertStatus 200 postRes+++    it "403s write requests without the CSRF header" $ runner $ do+        res <- request (defaultRequest { requestMethod = "POST" })+        assertStatus 403 res++    it "403s write requests with the wrong CSRF header" $ runner $ do+        getRes <- request defaultRequest+        assertStatus 200 getRes+        csrfValue <- fmap setCookieValue requireCsrfCookie++        res <- request (defaultRequest { requestMethod = "POST", requestHeaders = [(defaultCsrfHeaderName, csrfValue <> "foo")] })+        assertStatus 403 res++    it "403s write requests with the wrong CSRF param" $ runner $ do+        getRes <- request defaultRequest+        assertStatus 200 getRes+        csrfValue <- fmap setCookieValue requireCsrfCookie++        let body = "_token=" <> (csrfValue <> "foo")+        postRes <- srequest $ SRequest (defaultRequest { requestMethod = "POST", requestHeaders = [("Content-Type","application/x-www-form-urlencoded")] }) (fromStrict body)+        assertStatus 403 postRes+++requireCsrfCookie :: Session SetCookie+requireCsrfCookie = do+    cookies <- getClientCookies+    case Map.lookup defaultCsrfCookieName cookies of+        Just c -> return c+        Nothing -> error "Failed to lookup CSRF cookie"
test/YesodCoreTest/ErrorHandling.hs view
@@ -1,17 +1,38 @@-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+ module YesodCoreTest.ErrorHandling     ( errorHandlingTest     , Widget+    , resourcesApp     ) where++import  Data.Typeable(cast)+import qualified Control.Concurrent.Async as Async+import Control.Concurrent as Conc import Yesod.Core import Test.Hspec import Network.Wai import Network.Wai.Test-import Text.Hamlet (hamlet) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8-import Control.Exception (SomeException, try)+import Control.Exception (SomeException, try, AsyncException(..))+import Network.HTTP.Types (Status, mkStatus)+import Data.ByteString.Builder (Builder, toLazyByteString)+import Data.Text (Text, pack)+import Control.Monad (forM_)+import qualified Network.Wai.Handler.Warp as Warp+import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom+import Control.Monad.Trans.State (StateT (..))+import Control.Monad.Trans.Reader (ReaderT (..))+import qualified UnliftIO.Exception as E+import System.Timeout(timeout)  data App = App @@ -22,11 +43,34 @@ /after_runRequestBody AfterRunRequestBodyR POST /error-in-body ErrorInBodyR GET /error-in-body-noeval ErrorInBodyNoEvalR GET+/override-status OverrideStatusR GET+/error/#Int ErrorR GET++-- https://github.com/yesodweb/yesod/issues/658+/builder BuilderR GET+/file-bad-len FileBadLenR GET+/file-bad-name FileBadNameR GET++/good-builder GoodBuilderR GET++/auth-not-accepted AuthNotAcceptedR GET+/auth-not-adequate AuthNotAdequateR GET+/args-not-valid ArgsNotValidR POST+/only-plain-text OnlyPlainTextR GET++/thread-killed ThreadKilledR GET+/connection-closed-by-peer ConnectionClosedPeerR GET+/sleep-sec SleepASecR GET |] -instance Yesod App+overrideStatus :: Status+overrideStatus = mkStatus 15 "OVERRIDE" -getHomeR :: Handler RepHtml+instance Yesod App where+    errorHandler (InvalidArgs ["OVERRIDE"]) = sendResponseStatus overrideStatus ("OH HAI" :: String)+    errorHandler x = defaultErrorHandler x++getHomeR :: Handler Html getHomeR = do     $logDebug "Testing logging"     defaultLayout $ toWidget [hamlet|@@ -42,7 +86,7 @@       <input type=submit value="BUGGY: Error thrown after runRequestBody"> |] -postNotFoundR, postFirstThingR, postAfterRunRequestBodyR :: Handler RepHtml+postNotFoundR, postFirstThingR, postAfterRunRequestBodyR :: Handler Html postNotFoundR = do    (_, _files) <- runRequestBody    _ <- notFound@@ -57,14 +101,74 @@    _ <- error $ show $ fst x    getHomeR -getErrorInBodyR :: Handler RepHtml+getErrorInBodyR :: Handler Html getErrorInBodyR = do     let foo = error "error in body 19328" :: String     defaultLayout [whamlet|#{foo}|] -getErrorInBodyNoEvalR :: Handler (DontFullyEvaluate RepHtml)+getErrorInBodyNoEvalR :: Handler (DontFullyEvaluate Html) getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR +getOverrideStatusR :: Handler ()+getOverrideStatusR = invalidArgs ["OVERRIDE"]++getBuilderR :: Handler TypedContent+getBuilderR = return $ TypedContent "ignored" $ ContentBuilder (error "builder-3.14159") Nothing++getFileBadLenR :: Handler TypedContent+getFileBadLenR = return $ TypedContent "ignored" $ ContentFile "yesod-core.cabal" (error "filebadlen")++getFileBadNameR :: Handler TypedContent+getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing++goodBuilderContent :: Builder+goodBuilderContent = mconcat $ replicate 100 $ "This is a test\n"++getGoodBuilderR :: Handler TypedContent+getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent++-- this handler kills it's own thread+getThreadKilledR :: Handler Html+getThreadKilledR = do+  x <- liftIO Conc.myThreadId+  liftIO $ Async.withAsync (Conc.killThread x) Async.wait+  pure "unreachablle"+getSleepASecR :: Handler Html+getSleepASecR = do+  liftIO $ Conc.threadDelay 1000000+  pure "slept a second"++getConnectionClosedPeerR :: Handler Html+getConnectionClosedPeerR = do+  x <- liftIO Conc.myThreadId+  liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait+  pure "unreachablle"++getErrorR :: Int -> Handler ()+getErrorR 1 = setSession undefined "foo"+getErrorR 2 = setSession "foo" undefined+getErrorR 3 = deleteSession undefined+getErrorR 4 = addHeader undefined "foo"+getErrorR 5 = addHeader "foo" undefined+getErrorR 6 = expiresAt undefined+getErrorR 7 = setLanguage undefined+getErrorR 8 = cacheSeconds undefined+getErrorR 9 = setUltDest (undefined :: Text)+getErrorR 10 = setMessage undefined+getErrorR x = error $ "getErrorR: " ++ show x++getAuthNotAcceptedR :: Handler TypedContent+getAuthNotAcceptedR = notAuthenticated++getAuthNotAdequateR :: Handler TypedContent+getAuthNotAdequateR = permissionDenied "That doesn't belong to you. "++postArgsNotValidR :: Handler TypedContent+postArgsNotValidR = invalidArgs ["Doesn't matter.", "Don't want it."]++getOnlyPlainTextR :: Handler TypedContent+getOnlyPlainTextR = selectRep $ provideRepType "text/plain" $ return ("Only plain text." :: Text)+ errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling" $ do       it "says not found" caseNotFound@@ -72,8 +176,23 @@       it "says 'There was an error' after runRequestBody" caseAfter       it "error in body == 500" caseErrorInBody       it "error in body, no eval == 200" caseErrorInBodyNoEval+      it "can override status code" caseOverrideStatus+      it "builder" caseBuilder+      it "file with bad len" caseFileBadLen+      it "file with bad name" caseFileBadName+      it "builder includes content-length" caseGoodBuilder+      forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i)+      it "accept DVI file, invalid args -> 400" caseDviInvalidArgs+      it "accept audio, not authenticated -> 401" caseAudioNotAuthenticated+      it "accept CSS, permission denied -> 403" caseCssPermissionDenied+      it "accept image, non-existent path -> 404" caseImageNotFound+      it "accept video, bad method -> 405" caseVideoBadMethod+      it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows+      it "custom config rethrows an exception" caseCustomExceptionRethrows+      it "thread killed rethrow" caseThreadKilledRethrow+      it "can timeout a runner" canTimeoutARunner -runner :: Session () -> IO ()+runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f  caseNotFound :: IO ()@@ -120,8 +239,139 @@ caseErrorInBodyNoEval :: IO () caseErrorInBodyNoEval = do     eres <- try $ runner $ do-        _ <- request defaultRequest { pathInfo = ["error-in-body-noeval"] }-        return ()+        request defaultRequest { pathInfo = ["error-in-body-noeval"] }     case eres of         Left (_ :: SomeException) -> return ()-        Right _ -> error "Expected an exception"+        Right x -> error $ "Expected an exception, got: " ++ show x++caseOverrideStatus :: IO ()+caseOverrideStatus = runner $ do+    res <- request defaultRequest { pathInfo = ["override-status"] }+    assertStatus 15 res++caseBuilder :: IO ()+caseBuilder = runner $ do+    res <- request defaultRequest { pathInfo = ["builder"] }+    assertStatus 500 res+    assertBodyContains "builder-3.14159" res++caseFileBadLen :: IO ()+caseFileBadLen = runner $ do+    res <- request defaultRequest { pathInfo = ["file-bad-len"] }+    assertStatus 500 res+    assertBodyContains "filebadlen" res++caseFileBadName :: IO ()+caseFileBadName = runner $ do+    res <- request defaultRequest { pathInfo = ["file-bad-name"] }+    assertStatus 500 res+    assertBodyContains "filebadname" res++caseGoodBuilder :: IO ()+caseGoodBuilder = runner $ do+    res <- request defaultRequest { pathInfo = ["good-builder"] }+    assertStatus 200 res+    let lbs = toLazyByteString goodBuilderContent+    assertBody lbs res+    assertHeader "content-length" (S8.pack $ show $ L.length lbs) res++caseError :: Int -> IO ()+caseError i = runner $ do+    res <- request defaultRequest { pathInfo = ["error", pack $ show i] }+    ReaderT $ \r -> StateT $ \s -> runStateT (runReaderT (assertStatus 500 res) r) s `E.catch` \e -> do+        liftIO $ print res+        E.throwIO (e :: E.SomeException)++caseDviInvalidArgs :: IO ()+caseDviInvalidArgs = runner $ do+    res <- request defaultRequest+            { pathInfo = ["args-not-valid"]+            , requestMethod = "POST"+            , requestHeaders =+                ("accept", "application/x-dvi") : requestHeaders defaultRequest+            }+    assertStatus 400 res++caseAudioNotAuthenticated :: IO ()+caseAudioNotAuthenticated = runner $ do+    res <- request defaultRequest+            { pathInfo = ["auth-not-accepted"]+            , requestHeaders =+                ("accept", "audio/mpeg") : requestHeaders defaultRequest+            }+    assertStatus 401 res++caseCssPermissionDenied :: IO ()+caseCssPermissionDenied = runner $ do+    res <- request defaultRequest+            { pathInfo = ["auth-not-adequate"]+            , requestHeaders =+                ("accept", "text/css") : requestHeaders defaultRequest+            }+    assertStatus 403 res++caseImageNotFound :: IO ()+caseImageNotFound = runner $ do+    res <- request defaultRequest+            { pathInfo = ["not_a_path"]+            , requestHeaders =+                ("accept", "image/jpeg") : requestHeaders defaultRequest+            }+    assertStatus 404 res++caseVideoBadMethod :: IO ()+caseVideoBadMethod = runner $ do+    res <- request defaultRequest+            { pathInfo = ["good-builder"]+            , requestMethod = "DELETE"+            , requestHeaders =+                ("accept", "video/webm") : requestHeaders defaultRequest+            }+    assertStatus 405 res++fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e+fromExceptionUnwrap se+  | Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e+  | Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e+  | otherwise = E.fromException se+++caseThreadKilledRethrow :: IO ()+caseThreadKilledRethrow =+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of+                                (Just ThreadKilled) -> True+                                _ -> False+  where+  testcode = runner $ do+                res <- request defaultRequest { pathInfo = ["thread-killed"] }+                assertStatus 500 res+                assertBodyContains "Internal Server Error" res++caseDefaultConnectionCloseRethrows :: IO ()+caseDefaultConnectionCloseRethrows =+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of+                                  Just Warp.ConnectionClosedByPeer -> True+                                  _ -> False++  where+  testcode = runner $ do+      _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] }+      pure ()++caseCustomExceptionRethrows :: IO ()+caseCustomExceptionRethrows =+  shouldThrow testcode $ \case Custom.MkMyException -> True+  where+    testcode = customAppRunner $ do+      _res <- request defaultRequest { pathInfo = ["throw-custom-exception"] }+      pure ()+    customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f+++canTimeoutARunner :: IO ()+canTimeoutARunner = do+  res <- timeout 1000 $ runner $ do+    res <- request defaultRequest { pathInfo = ["sleep-sec"] }+    assertStatus 200 res -- if 500, it's catching the timeout exception+    pure () -- it should've timeout by now, either being 500 or Nothing+  res `shouldBe` Nothing -- make sure that pure statement didn't happen.
+ test/YesodCoreTest/ErrorHandling/CustomApp.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | a custom app that throws an exception+module YesodCoreTest.ErrorHandling.CustomApp+    (CustomApp(..)+    , MyException(..)++    -- * unused+    , Widget+    , resourcesCustomApp+    ) where++import Yesod.Core+import qualified UnliftIO.Exception as E++data CustomApp = CustomApp++mkYesod "CustomApp" [parseRoutes|+/throw-custom-exception CustomHomeR GET+|]++getCustomHomeR :: Handler Html+getCustomHomeR =+  E.throwIO MkMyException++data MyException = MkMyException+ deriving (Show, E.Exception)++instance Yesod CustomApp where+  -- something we couldn't do before, rethrow custom exceptions+  catchHandlerExceptions _ action handler =+    action `E.catch` \exception -> do+      case E.fromException exception of+        Just MkMyException -> E.throwIO MkMyException+        Nothing -> handler exception
test/YesodCoreTest/Exceptions.hs view
@@ -1,11 +1,21 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}-module YesodCoreTest.Exceptions (exceptionsTest, Widget) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} +module YesodCoreTest.Exceptions+    ( exceptionsTest+    , Widget+    , resourcesY+    ) where+ import Test.Hspec -import Yesod.Core hiding (Request)+import Yesod.Core+import Yesod.Core.Types (TypedContent, HandlerContents (HCError))+import Control.Exception (throwIO) import Network.Wai import Network.Wai.Test import Network.HTTP.Types (status301)@@ -14,11 +24,15 @@ mkYesod "Y" [parseRoutes| / RootR GET /redirect RedirR GET+/impure ImpureR GET |]  instance Yesod Y where     approot = ApprootStatic "http://test"-    errorHandler (InternalError e) = return $ chooseRep $ RepPlain $ toContent e+    errorHandler (InternalError e) = do+        _ <- return $! e+        addHeader "ERROR" "HANDLER"+        return $ toTypedContent e     errorHandler x = defaultErrorHandler x  getRootR :: Handler ()@@ -26,13 +40,17 @@  getRedirR :: Handler () getRedirR = do-    setHeader "foo" "bar"+    addHeader "foo" "bar"     redirectWith status301 RootR +getImpureR :: Handler ()+getImpureR = liftIO $ throwIO $ HCError $ InternalError $ error "impure!"+ exceptionsTest :: Spec exceptionsTest = describe "Test.Exceptions" $ do       it "500" case500       it "redirect keeps headers" caseRedirect+      it "deals with impure InternalError values" caseImpure  runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f@@ -41,10 +59,17 @@ case500 = runner $ do     res <- request defaultRequest     assertStatus 500 res-    assertBody "FOOBAR" res+    assertBodyContains "FOOBAR" res  caseRedirect :: IO () caseRedirect = runner $ do     res <- request defaultRequest { pathInfo = ["redirect"] }     assertStatus 301 res     assertHeader "foo" "bar" res++caseImpure :: IO ()+caseImpure = runner $ do+    res <- request defaultRequest { pathInfo = ["impure"] }+    assertStatus 500 res+    assertBodyContains "impure!" res+    assertHeader "ERROR" "HANDLER" res
+ test/YesodCoreTest/FallthroughDispatch/Resources.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Shared route table + foundation type for "YesodCoreTest.FallthroughDispatch.Runtime".+-- Two parents share the @\/foo@ prefix (@FirstFooR@\/@SecondFooR@), plus+-- @\/foo\/#Int@ and @\/foo\/#String@ parents — the deliberate overlap is why it+-- uses @parseRoutesNoCheck@ (the compile-time overlap check would otherwise+-- reject the shared prefix that the fallthrough behaviour exists to handle).+module YesodCoreTest.FallthroughDispatch.Resources where++import Yesod.Core+import Yesod.Routes.TH.Types++data App = App++fallthroughDispatchResources :: [ResourceTree String]+fallthroughDispatchResources = [parseRoutesNoCheck|++/foo   FirstFooR:+    /   FooIndexR+    /neat   FooNeatR++/foo   SecondFooR:+    /       NeverFiresR+    /other  OtherR++/foo/#Int  ParamFooR:+    /   FooWithIntR++/foo/#String TextFooR:+    /   FooWithTextR+|]
+ test/YesodCoreTest/FallthroughDispatch/Runtime.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | The single-module fallthrough contract demo for a top-level site, built+-- with @setNestedRouteFallthrough True@. Two same-prefix parents share @\/foo@:+-- @FirstFooR@ (with an index + @\/neat@) and @SecondFooR@ (@\/other@). With+-- fallthrough on, a request that misses inside @FirstFooR@ continues to the+-- sibling @SecondFooR@ instead of committing to @FirstFooR@'s 404 — the WAI+-- specs here pin exactly which parent serves each path. Route table in+-- ".FallthroughDispatch.Resources".+module YesodCoreTest.FallthroughDispatch.Runtime where++import YesodCoreTest.FallthroughDispatch.Resources+import YesodCoreTest.RuntimeHarness (assertGet)+import Yesod.Core+import Test.Hspec++mkYesodOpts (setNestedRouteFallthrough True defaultOpts) "App" fallthroughDispatchResources++instance Yesod App++handleFooIndexR :: HandlerFor app String+handleFooIndexR = pure "FooIndexR"++handleOtherR :: HandlerFor app String+handleOtherR = pure "OtherR"++handleFooNeatR :: HandlerFor app String+handleFooNeatR = pure "FooNeatR"++handleNeverFiresR :: HandlerFor app String+handleNeverFiresR = pure "NeverFiresR"++handleFooWithIntR :: Int -> HandlerFor app String+handleFooWithIntR i = pure $ "FooWithIntR " <> show i++handleFooWithTextR :: String -> HandlerFor app String+handleFooWithTextR str = pure $ "FooWithTextR " <> str++spec :: Spec+spec = do+    describe "FirstFooR" $ do+        it "FooIndexR" $ do+            assertGet App 200 ["foo"] (Just "FooIndexR")++        it "FooNeatR" $ do+            assertGet App 200 ["foo", "neat"] (Just "FooNeatR")++    describe "SecondFooR" $ do+        -- This is a little unsatisfying. Ideally we could write a test+        -- that expresses that, uh, `renderRoute (SecondFooR NeverFiresR)`+        -- would always direct to a different route. Difficult to do+        -- though.+        it "NeverFiresR" $ do+            assertGet App 200 ["foo"] (Just "FooIndexR")++        it "OtherR" $ do+            assertGet App 200 ["foo", "other"] (Just "OtherR")++    describe "ParamFooR" $ do+        it "FooWithIntR" $ do+            assertGet App 200 ["foo", "3"] (Just "FooWithIntR 3")++    describe "TextFooR" $ do+        it "FooWithTextR" $ do+            assertGet App 200 ["foo", "asdf"] (Just "FooWithTextR asdf")
+ test/YesodCoreTest/FallthroughMatrix/FirstFoo.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | The split-out nested-dispatch instance for @FirstFooR@, generated with the+-- DEFAULT route options — i.e. @fallthrough = False@. The @FooIndexR@\/@FooNeatR@+-- handlers live ONLY here, so the top module ("YesodCoreTest.FallthroughMatrix.Runtime") can+-- compile only by delegating to the @YesodDispatchNested FirstFooR@ instance+-- generated by this splice (it cannot inline handlers it can't see).+--+-- This module's flag is @False@, but a nested instance must still report a+-- path miss as 'Nothing' rather than baking a 404 into its own terminal+-- fallback — the fallthrough decision belongs to whichever module delegates+-- to it. An instance that 404s on its own would silently defeat the top+-- module's @fallthrough = True@ intent.+module YesodCoreTest.FallthroughMatrix.FirstFoo where++import Yesod.Core+import YesodCoreTest.FallthroughMatrix.Resources++mkYesodOpts (setFocusOnNestedRoute "FirstFooR" defaultOpts) "FMApp" fmResources++getFooIndexR :: HandlerFor FMApp String+getFooIndexR = pure "FooIndexR"++getFooNeatR :: HandlerFor FMApp String+getFooNeatR = pure "FooNeatR"
+ test/YesodCoreTest/FallthroughMatrix/Resources.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Shared route table + site type for the cross-module fallthrough matrix.+--+-- Two parents share the @\/foo@ prefix: @FirstFooR@ (whose nested instance is+-- generated in a /separate/ module, "YesodCoreTest.FallthroughMatrix.FirstFoo",+-- with the default @fallthrough = False@) and @SecondFooR@ (inlined in the+-- top module "YesodCoreTest.FallthroughMatrix.Runtime", which sets+-- @fallthrough = True@). The flag mismatch across the module split is the whole+-- point: it lets us pin who owns the terminal 404 on @\/foo\/other@.+--+-- @FirstFooR@ owns @\/foo\/neat@ as @GET@-only; @SecondFooR@ owns the same+-- @\/foo\/neat@ path as @POST@-only. This shared @neat@ leaf is what pins the+-- wrong-method contract under fallthrough: a @POST \/foo\/neat@ matches+-- @FirstFooR@'s @GET@ leaf /by path/ and so must commit to 405 — fallthrough is+-- only triggered by a path miss ('Nothing'), and a matched-path/wrong-method+-- leaf returns @Just \<405\>@, never 'Nothing'. If it instead fell through to+-- @SecondFooR@'s @POST@ leaf it would 200, which would be a contract change.+module YesodCoreTest.FallthroughMatrix.Resources where++import Yesod.Core+import Yesod.Routes.TH.Types++data FMApp = FMApp++fmResources :: [ResourceTree String]+fmResources = [parseRoutesNoCheck|+/foo   FirstFooR:+    /      FooIndexR  GET+    /neat  FooNeatR   GET++/foo   SecondFooR:+    /       NeverFiresR  GET+    /other  OtherR       GET+    /neat   NeatPostR    POST+|]
+ test/YesodCoreTest/FallthroughMatrix/Runtime.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Cross-module fallthrough flag mismatch: the delegating module and the+-- split-out nested instance are compiled with opposite fallthrough flags.+--+-- This top module sets @fallthrough = True@ and delegates @FirstFooR@ to the+-- nested instance generated (with the default @fallthrough = False@) in+-- "YesodCoreTest.FallthroughMatrix.FirstFoo". @SecondFooR@ is inlined here.+--+-- The single-module analogue "YesodCoreTest.ParamFallthroughRuntime" proves+-- that with fallthrough enabled, @\/foo\/other@ falls through @FirstFooR@ (which+-- has no @other@ child) to @SecondFooR@ → @OtherR@ (200). This module is the+-- same shape but with @FirstFooR@'s instance split into a module compiled with+-- the opposite flag — the configuration that only works because a nested+-- instance reports a path miss as 'Nothing' instead of baking in its own 404,+-- leaving the fallthrough decision to the module that delegates to it.+module YesodCoreTest.FallthroughMatrix.Runtime+    ( specs+    ) where++import Test.Hspec+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Yesod.Core++import YesodCoreTest.FallthroughMatrix.Resources+import YesodCoreTest.FallthroughMatrix.FirstFoo (FirstFooR(..))+import YesodCoreTest.RuntimeHarness (assertGet, assertRequestFor)++mkYesodOpts (setNestedRouteFallthrough True defaultOpts) "FMApp" fmResources++instance Yesod FMApp where+    messageLoggerSource = mempty++getNeverFiresR :: HandlerFor FMApp String+getNeverFiresR = pure "NeverFiresR"++getOtherR :: HandlerFor FMApp String+getOtherR = pure "OtherR"++postNeatPostR :: HandlerFor FMApp String+postNeatPostR = pure "NeatPostR"++testRequestIO :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO ()+testRequestIO = assertGet FMApp++specs :: Spec+specs = describe "cross-module fallthrough flag mismatch (top True, split child False)" $ do+    it "matches the split child's index (FooIndexR at /foo)" $+        testRequestIO 200 ["foo"] (Just "FooIndexR")+    it "matches a child of the split parent (FooNeatR at /foo/neat)" $+        testRequestIO 200 ["foo", "neat"] (Just "FooNeatR")+    it "falls through the split parent to the inline sibling (OtherR at /foo/other)" $+        -- The headline case. The top module wants fallthrough; FirstFooR has+        -- no "other" child, so dispatch falls through to SecondFooR's OtherR+        -- (200). If FirstFooR's split instance (compiled with flag False)+        -- instead baked a 404 into its own terminal fallback, it would defeat+        -- the parent's fallthrough.+        testRequestIO 200 ["foo", "other"] (Just "OtherR")++    -- Terminal semantics of fallthrough. Fallthrough is triggered+    -- ONLY by a path-level miss (a 'Nothing' from the matched parent): a+    -- matched leaf — even one rejecting the method — returns @Just <405>@, so+    -- dispatch commits to that leaf and never falls through to a same-prefix+    -- sibling. These rows pin both halves of that contract.+    describe "wrong method on a matched leaf commits (does not fall through)" $ do+        it "POST /foo/neat commits to 405 at FirstFooR's GET leaf" $+            -- FirstFooR owns /foo/neat as GET-only and SecondFooR owns the same+            -- /foo/neat path as POST-only. A POST matches FirstFooR's leaf by+            -- PATH, so the split (fallthrough=False) FirstFooR instance returns+            -- Just <405> — it does NOT return Nothing — and the host's+            -- fallthrough arm therefore commits to 405 rather than falling+            -- through to SecondFooR's POST leaf (which would be 200). If this+            -- ever flips to 200, fallthrough has started swallowing a matched+            -- leaf's method rejection, which is a contract change.+            assertRequestFor FMApp "POST" 405 ["foo", "neat"] Nothing+        it "GET /foo/neat still serves FirstFooR's GET leaf (200)" $+            -- The mirror of the above: the same shared path under the right+            -- method resolves to the first matching leaf, never SecondFooR.+            testRequestIO 200 ["foo", "neat"] (Just "FooNeatR")++    describe "total miss under fallthrough lands on the terminal 404" $ do+        it "GET /foo/zzz exhausts both same-prefix parents -> 404" $+            -- /foo/zzz matches the /foo prefix of both FirstFooR and SecondFooR+            -- but no leaf of either. Each parent reports a path miss ('Nothing'),+            -- so dispatch falls through every sibling and lands on the terminal+            -- 404 clause ("except in the final case" from the flag's haddock).+            testRequestIO 404 ["foo", "zzz"] Nothing+        it "GET /zzz matches no parent prefix at all -> 404" $+            -- A top-level total miss: no parent's prefix matches, so the only+            -- clause that fires is the terminal 404.+            testRequestIO 404 ["zzz"] Nothing
+ test/YesodCoreTest/Header.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module YesodCoreTest.Header+  ( headerTest+  , Widget+  , resourcesApp+  ) where++import Data.Text (Text)+import Network.HTTP.Types (decodePathSegments)+import Network.Wai+import Network.Wai.Test+import Test.Hspec+import Yesod.Core++data App =+  App++mkYesod+  "App"+  [parseRoutes|+/header1 Header1R GET+/header2 Header2R GET+/header3 Header3R GET+|]++instance Yesod App++getHeader1R :: Handler RepPlain+getHeader1R = do+  addHeader "hello" "world"+  return $ RepPlain $ toContent ("header test" :: Text)++getHeader2R :: Handler RepPlain+getHeader2R = do+  addHeader "hello" "world"+  replaceOrAddHeader "hello" "sibi"+  return $ RepPlain $ toContent ("header test" :: Text)++getHeader3R :: Handler RepPlain+getHeader3R = do+  addHeader "hello" "world"+  addHeader "michael" "snoyman"+  addHeader "yesod" "framework"+  replaceOrAddHeader "yesod" "book"+  return $ RepPlain $ toContent ("header test" :: Text)++runner :: Session () -> IO ()+runner f = toWaiApp App >>= runSession f++addHeaderTest :: IO ()+addHeaderTest =+  runner $ do+    res <- request defaultRequest {pathInfo = decodePathSegments "/header1"}+    assertHeader "hello" "world" res++multipleHeaderTest :: IO ()+multipleHeaderTest =+  runner $ do+    res <- request defaultRequest {pathInfo = decodePathSegments "/header2"}+    assertHeader "hello" "sibi" res++header3Test :: IO ()+header3Test = do+  runner $ do+    res <- request defaultRequest {pathInfo = decodePathSegments "/header3"}+    assertHeader "hello" "world" res+    assertHeader "michael" "snoyman" res+    assertHeader "yesod" "book" res++xssHeaderTest :: IO ()+xssHeaderTest = do+  runner $ do+    res <- request defaultRequest {pathInfo = decodePathSegments "/header1"}+    assertHeader "X-XSS-Protection" "1; mode=block" res++headerTest :: Spec+headerTest =+  describe "Test.Header" $ do+    it "addHeader" addHeaderTest+    it "multiple header" multipleHeaderTest+    it "persist headers" header3Test+    it "has X-XSS-Protection: 1; mode=block" xssHeaderTest
test/YesodCoreTest/InternalRequest.hs view
@@ -1,33 +1,52 @@ {-# LANGUAGE OverloadedStrings #-}+ module YesodCoreTest.InternalRequest (internalRequestTest) where  import Data.List (nub)-import System.Random (StdGen, mkStdGen)- import Network.Wai as W-import Network.Wai.Test-import Yesod.Internal.TestApi (randomString, parseWaiRequest')-import Yesod.Request (Request (..))+import Yesod.Core.Internal (randomString, parseWaiRequest) import Test.Hspec+import Data.Map (singleton)+import Yesod.Core+import Data.Word (Word64)+import System.IO.Unsafe (unsafePerformIO)+import Control.Monad (replicateM)+import System.Random (randomIO) +gen :: IO Int+gen = randomIO+ randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do-    it "looks reasonably random" looksRandom+    --it "looks reasonably random" looksRandom     it "does not repeat itself" $ noRepeat 10 100  -- NOTE: this testcase may break on other systems/architectures if -- mkStdGen is not identical everywhere (is it?).-looksRandom :: Bool-looksRandom = randomString 20 (mkStdGen 0) == "VH9SkhtptqPs6GqtofVg"+_looksRandom :: IO ()+_looksRandom = do+    s <- randomString 20 gen+    s `shouldBe` "VH9SkhtptqPs6GqtofVg" -noRepeat :: Int -> Int -> Bool-noRepeat len n = length (nub $ map (randomString len . mkStdGen) [1..n]) == n+noRepeat :: Int -> Int -> IO ()+noRepeat len n = do+    ss <- replicateM n $ randomString len gen+    length (nub ss) `shouldBe` n   -- For convenience instead of "(undefined :: StdGen)".-g :: StdGen+g :: IO Int g = error "test/YesodCoreTest/InternalRequest.g" +parseWaiRequest' :: Request+                 -> SessionMap+                 -> Bool+                 -> Word64+                 -> YesodRequest+parseWaiRequest' a b c d = unsafePerformIO $ -- ugly hack, just to ease migration, should be removed+    case parseWaiRequest a b c (Just d) of+        Left yreq -> yreq+        Right needGen -> needGen g  tokenSpecs :: Spec tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do@@ -38,19 +57,19 @@  noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where-  r = parseWaiRequest' defaultRequest [] False 0 1000 g+  r = parseWaiRequest' defaultRequest mempty False 1000  ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where-  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 0 1000 g+  r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") False 1000  useOldToken :: Bool useOldToken = reqToken r == Just "old" where-  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 1000 g+  r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000  generateToken :: Bool generateToken = reqToken r /= Nothing where-  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 1000 g+  r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000   langSpecs :: Spec@@ -64,21 +83,21 @@ respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where   r = parseWaiRequest' defaultRequest-        { requestHeaders = [("Accept-Language", "en-US, es")] } [] False 0 1000 g+        { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000  respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where-  r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 0 1000 g+  r = parseWaiRequest' defaultRequest (singleton "_LANG" "en") False 1000  respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where   r = parseWaiRequest' defaultRequest         { requestHeaders = [("Cookie", "_LANG=en")]-        } [] False 0 1000 g+        } mempty False 1000  respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where-  r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 0 1000 g+  r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000  prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where@@ -87,8 +106,7 @@                            , ("Cookie", "_LANG=en-COOKIE")                            ]         , queryString = [("_LANG", Just "en-QUERY")]-        } [("_LANG", "en-SESSION")] False 0 10000 g-+        } (singleton "_LANG" "en-SESSION") False 10000  internalRequestTest :: Spec internalRequestTest = describe "Test.InternalRequestTest" $ do
+ test/YesodCoreTest/JsAttributes.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module YesodCoreTest.JsAttributes+    ( specs+      -- To avoid unused warning+    , Widget+    , resourcesApp+    ) where++import Test.Hspec++import Yesod.Core+import Network.Wai.Test++data App = App+mkYesod "App" [parseRoutes|+/ HeadR GET+|]+instance Yesod App where+    jsAttributes _ = [("attr0", "a")]++getHeadR :: Handler Html+getHeadR = defaultLayout $ do+    addScriptRemote "load.js"+    toWidget [julius|/*body*/|]+    toWidgetHead [julius|/*head*/|]++specs :: Spec+specs = describe "Test.JsAttributes" $ do+    it "script in body gets attributes" $ runner App $ do+      res <- request defaultRequest+      assertBody "<!DOCTYPE html>\n<html><head><title></title><script>/*head*/</script></head><body><script src=\"load.js\"></script><script attr0=\"a\">/*body*/</script></body></html>" res++runner :: YesodDispatch master => master -> Session () -> IO ()+runner app f = toWaiApp app >>= runSession f
test/YesodCoreTest/JsLoader.hs view
@@ -1,14 +1,21 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}-module YesodCoreTest.JsLoader (specs, Widget) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} -import YesodCoreTest.JsLoaderSites.HeadAsync (HA(..))+module YesodCoreTest.JsLoader+    ( specs+    , Widget+    , resourcesH+    ) where+ import YesodCoreTest.JsLoaderSites.Bottom (B(..))  import Test.Hspec -import Yesod.Core hiding (Request)+import Yesod.Core import Network.Wai.Test  data H = H@@ -18,7 +25,7 @@ instance Yesod H where     jsLoader _ = BottomOfHeadBlocking -getHeadR :: Handler RepHtml+getHeadR :: Handler Html getHeadR = defaultLayout $ addScriptRemote "load.js"  specs :: Spec@@ -27,13 +34,9 @@       res <- request defaultRequest       assertBody "<!DOCTYPE html>\n<html><head><title></title><script src=\"load.js\"></script></head><body></body></html>" res -    it "link from head async" $ runner HA $ do-      res <- request defaultRequest-      assertBody "<!DOCTYPE html>\n<html><head><title></title><script src=\"yepnope.js\"></script><script>yepnope({load:[\"load.js\"]});</script></head><body></body></html>" res-     it "link from bottom" $ runner B $ do       res <- request defaultRequest       assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><script src=\"load.js\"></script></body></html>" res -runner :: (YesodDispatch master master, Yesod master) => master -> Session () -> IO ()+runner :: YesodDispatch master => master -> Session () -> IO () runner app f = toWaiApp app >>= runSession f
test/YesodCoreTest/JsLoaderSites/Bottom.hs view
@@ -1,8 +1,16 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}-module YesodCoreTest.JsLoaderSites.Bottom (B(..), Widget) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} +module YesodCoreTest.JsLoaderSites.Bottom+    ( B(..)+    , Widget+    , resourcesB -- avoid warning+    ) where+ import Yesod.Core  data B = B@@ -12,6 +20,5 @@ instance Yesod B where   jsLoader _ = BottomOfBody -getBottomR :: Handler RepHtml+getBottomR :: Handler Html getBottomR = defaultLayout $ addScriptRemote "load.js"-
− test/YesodCoreTest/JsLoaderSites/HeadAsync.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-module YesodCoreTest.JsLoaderSites.HeadAsync (HA(..), Widget) where--import Yesod.Core--data HA = HA-mkYesod "HA" [parseRoutes|-/ HeadAsyncR GET-|]-instance Yesod HA where-  jsLoader _ = BottomOfHeadAsync $ loadJsYepnope $ Left "yepnope.js"--getHeadAsyncR :: Handler RepHtml-getHeadAsyncR = defaultLayout $ addScriptRemote "load.js"
+ test/YesodCoreTest/Json.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module YesodCoreTest.Json+    ( specs+    , Widget+    , resourcesApp+    ) where++import Yesod.Core+import Test.Hspec+import qualified Data.Map as Map+import Network.Wai.Test+import Data.Text (Text)+import Data.ByteString.Lazy (ByteString)++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET+/has-multiple-pieces/#Int/#Int MultiplePiecesR GET+|]++instance Yesod App++getHomeR :: Handler RepPlain+getHomeR = do+    val <- requireInsecureJsonBody+    case Map.lookup ("foo" :: Text) val of+        Nothing -> invalidArgs ["foo not found"]+        Just foo -> return $ RepPlain $ toContent (foo :: Text)++getMultiplePiecesR :: Int -> Int -> Handler ()+getMultiplePiecesR _ _ = return ()++test :: String+     -> ByteString+     -> (SResponse -> Session ())+     -> Spec+test name rbody f = it name $ do+    app <- toWaiApp App+    flip runSession app $ do+        sres <- srequest SRequest+            { simpleRequest = defaultRequest+            , simpleRequestBody = rbody+            }+        f sres++specs :: Spec+specs = describe "Yesod.Json" $ do+    test "parses valid content" "{\"foo\":\"bar\"}" $ \sres -> do+        assertStatus 200 sres+        assertBody "bar" sres+    test "400 for bad JSON" "{\"foo\":\"bar\"" $ \sres -> do+        assertStatus 400 sres+    test "400 for bad structure" "{\"foo2\":\"bar\"}" $ \sres -> do+        assertStatus 400 sres+        assertBodyContains "foo not found" sres
test/YesodCoreTest/Links.hs view
@@ -1,36 +1,78 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}-module YesodCoreTest.Links (linksTest, Widget) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} +module YesodCoreTest.Links+    ( linksTest+    , Widget+    , resourcesY+    ) where+ import Test.Hspec -import Yesod.Core hiding (Request)-import Text.Hamlet+import Yesod.Core import Network.Wai import Network.Wai.Test import Data.Text (Text)-import Control.Monad.IO.Class (liftIO)-import Blaze.ByteString.Builder (toByteString)+import Data.ByteString.Builder (toLazyByteString)  data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /single/#Text TextR GET /multi/*Texts TextsR GET++/route-test-1/+[Text] RT1 GET+/route-test-2/*Vector-String RT2 GET+/route-test-3/*Vector-(Maybe-Int) RT3 GET+/route-test-4/#(Foo-Int-Int) RT4 GET+/route-test-4-spaces/#{Foo Int Int} RT4Spaces GET |] +data Vector a = Vector+    deriving (Show, Read, Eq)++instance PathMultiPiece (Vector a) where+    toPathMultiPiece = error "toPathMultiPiece"+    fromPathMultiPiece = error "fromPathMultiPiece"++data Foo x y = Foo+    deriving (Show, Read, Eq)++instance PathPiece (Foo x y) where+    toPathPiece = error "toPathPiece"+    fromPathPiece = error "fromPathPiece"+ instance Yesod Y -getRootR :: Handler RepHtml+getRootR :: Handler Html getRootR = defaultLayout $ toWidget [hamlet|<a href=@{RootR}>|] -getTextR :: Text -> Handler RepHtml+getTextR :: Text -> Handler Html getTextR foo = defaultLayout $ toWidget [hamlet|%#{foo}%|] -getTextsR :: [Text] -> Handler RepHtml+getTextsR :: [Text] -> Handler Html getTextsR foos = defaultLayout $ toWidget [hamlet|%#{show foos}%|] +getRT1 :: [Text] -> Handler ()+getRT1 _ = return ()++getRT2 :: Vector String -> Handler ()+getRT2 _ = return ()++getRT3 :: Vector (Maybe Int) -> Handler ()+getRT3 _ = return ()++getRT4 :: Foo Int Int -> Handler ()+getRT4 _ = return ()++getRT4Spaces :: Foo Int Int -> Handler ()+getRT4Spaces _ = return ()+ linksTest :: Spec linksTest = describe "Test.Links" $ do       it "linkToHome" case_linkToHome@@ -49,7 +91,7 @@     liftIO $ do         let go r =                 let (ps, qs) = renderRoute r-                 in toByteString $ joinPath Y "" ps qs+                 in toLazyByteString $ joinPath Y "" ps qs         (go $ TextR "-") `shouldBe` "/single/--"         (go $ TextR "") `shouldBe` "/single/-"         (go $ TextsR ["", "-", "foo", "", "bar"]) `shouldBe` "/multi/-/--/foo/-/bar"
+ test/YesodCoreTest/LiteApp.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+module YesodCoreTest.LiteApp (specs) where++import Yesod.Core+import Test.Hspec+import Network.Wai.Test+import Network.Wai+import qualified Data.ByteString.Char8 as S8+import qualified Data.Text as T+import qualified Data.ByteString.Lazy.Char8 as L8++iapp :: IO Application+iapp = toWaiApp $ liteApp $ do+    onMethod (S8.pack "GET") (dispatchTo $ return "GetHomepage")+    onMethod (S8.pack "POST") (dispatchTo $ return "PostHomepage")+    onStatic (T.pack "string") (withDynamic (\t -> dispatchTo $ return (t :: T.Text)))+    onStatic (T.pack "multi") (withDynamicMulti (\[_, y] -> dispatchTo $ return (y :: T.Text)))++test :: String -- ^ method+     -> [String] -- ^ path+     -> (Either Int String) -- ^ status code or body+     -> Spec+test method path expected = it (method ++ " " ++ show path) $ do+    app <- iapp+    flip runSession app $ do+        sres <- request defaultRequest+            { requestMethod = S8.pack method+            , pathInfo = map T.pack path+            }+        case expected of+            Left i -> assertStatus i sres+            Right b -> assertBody (L8.pack b) sres++specs :: Spec+specs = describe "LiteApp" $ do+    test "GET" [] $ Right "GetHomepage"+    test "POST" [] $ Right "PostHomepage"+    -- test "PUT" [] $ Left 405+    test "GET" ["string", "foo"] $ Right "foo"+    test "DELETE" ["string", "bar"] $ Right "bar"+    test "GET" ["string!", "foo"] $ Left 404+    test "GET" ["multi", "foo", "bar"] $ Right "bar"+    test "GET" ["multi", "foo", "bar", "baz"] $ Left 500
test/YesodCoreTest/Media.hs view
@@ -1,36 +1,39 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ module YesodCoreTest.Media (mediaTest, Widget) where  import Test.Hspec-import Yesod.Core hiding (Request)+import Yesod.Core import Network.Wai import Network.Wai.Test-import Text.Lucius import YesodCoreTest.MediaData  mkYesodDispatch "Y" resourcesY  instance Yesod Y where     addStaticContent _ _ content = do-        tm <- getRouteToMaster         route <- getCurrentRoute-        case fmap tm route of+        case route of             Just StaticR -> return $ Just $ Left $                         if content == "foo2{bar:baz}"                             then "screen.css"                             else "all.css"             _ -> return Nothing -getRootR :: Handler RepHtml+getRootR :: Handler Html getRootR = defaultLayout $ do     toWidget [lucius|foo1{bar:baz}|]-    addCassiusMedia "screen" [lucius|foo2{bar:baz}|]+    toWidgetMedia "screen" [lucius|foo2{bar:baz}|]     toWidget [lucius|foo3{bar:baz}|] -getStaticR :: Handler RepHtml+getStaticR :: Handler Html getStaticR = getRootR  runner :: Session () -> IO ()
test/YesodCoreTest/MediaData.hs view
@@ -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@@ -8,5 +12,5 @@ data Y = Y mkYesodData "Y" [parseRoutes| / RootR GET-/static StaticR GET+/static StaticR !IGNORED GET !alsoIgnored |]
+ test/YesodCoreTest/Meta.hs view
@@ -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 "<!DOCTYPE html>\n<html><head><title>Second title</title></head><body></body></html>" res+    describe "Yesod.Core.Widget.setDescriptionIdemp" $ do+        it "is idempotent" $ runner $ do+            res <- request defaultRequest+                        { pathInfo = ["desc"]+                        }+            assertBody "<!DOCTYPE html>\n<html><head><title></title><meta name=\"description\" content=\"Second description\"></head><body></body></html>" res++runner :: Session () -> IO ()+runner f = toWaiAppPlain App >>= runSession f
+ test/YesodCoreTest/MultiPieceNestedRuntime.hs view
@@ -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
+ test/YesodCoreTest/NestedDispatch/InnerR.hs view
@@ -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"
+ test/YesodCoreTest/NestedDispatch/NestR.hs view
@@ -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"
+ test/YesodCoreTest/NestedDispatch/Parent0R.hs view
@@ -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))
+ test/YesodCoreTest/NestedDispatch/Parent0R/Child0R.hs view
@@ -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
+ test/YesodCoreTest/NestedDispatch/ParentR.hs view
@@ -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)))
+ test/YesodCoreTest/NestedDispatch/Resources.hs view
@@ -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+|]
+ test/YesodCoreTest/NestedDispatch/Runtime.hs view
@@ -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"))
test/YesodCoreTest/NoOverloadedStrings.hs view
@@ -1,25 +1,54 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where+{-# 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+    , resourcesY+    ) where+ import Test.Hspec+import YesodCoreTest.NoOverloadedStringsSub -import Yesod.Core hiding (Request)+import Yesod.Core+import Network.Wai import Network.Wai.Test-import Data.Monoid (mempty)--data Subsite = Subsite+import qualified Data.Text as T+import qualified Data.ByteString.Lazy.Char8 as L8  getSubsite :: a -> Subsite-getSubsite = const Subsite+getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite) -mkYesodSub "Subsite" [] [parseRoutes|-/bar BarR GET-|]+getBarR :: MonadHandler m => m T.Text+getBarR = return $ T.pack "BarR" -getBarR :: GHandler Subsite m ()-getBarR = return ()+getBazR :: (MonadHandler m, Yesod (HandlerSite m)) => m Html+getBazR = liftHandler $ defaultLayout [whamlet|Used Default Layout|] +getBinR :: (MonadHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html+getBinR = do+    routeToParent <- getRouteToParent+    liftHandler $ defaultLayout [whamlet|+        <p>Used defaultLayoutT+        <a href=@{routeToParent BazR}>Baz+    |]++getOnePiecesR :: Monad m => Int -> m ()+getOnePiecesR _ = return ()++getTwoPiecesR :: Monad m => Int -> Int -> m ()+getTwoPiecesR _ _ = return ()++getThreePiecesR :: Monad m => Int -> Int -> Int -> m ()+getThreePiecesR _ _ _ = return ()+ data Y = Y mkYesod "Y" [parseRoutes| / RootR GET@@ -43,6 +72,33 @@     res <- request defaultRequest     assertBody mempty res +case_subsite :: IO ()+case_subsite = runner $ do+    res <- request defaultRequest+        { pathInfo = map T.pack ["subsite", "bar"]+        }+    assertBody (L8.pack "BarR") res+    assertStatus 200 res++case_deflayout :: IO ()+case_deflayout = runner $ do+    res <- request defaultRequest+        { pathInfo = map T.pack ["subsite", "baz"]+        }+    assertBodyContains (L8.pack "Used Default Layout") res+    assertStatus 200 res++case_deflayoutT :: IO ()+case_deflayoutT = runner $ do+    res <- request defaultRequest+        { pathInfo = map T.pack ["subsite", "bin"]+        }+    assertBodyContains (L8.pack "Used defaultLayoutT") res+    assertStatus 200 res+ noOverloadedTest :: Spec noOverloadedTest = describe "Test.NoOverloadedStrings" $ do       it "sanity" case_sanity+      it "subsite" case_subsite+      it "deflayout" case_deflayout+      it "deflayoutT" case_deflayoutT
+ test/YesodCoreTest/NoOverloadedStringsSub.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} -- hah, the test should be renamed...+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- 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++import Yesod.Core+import Yesod.Core.Types++data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master -> Application)++mkYesodSubData "Subsite" [parseRoutes|+/bar BarR GET+/baz BazR GET+/bin BinR GET+/has-one-piece/#Int OnePiecesR GET+/has-two-pieces/#Int/#Int TwoPiecesR GET+/has-three-pieces/#Int/#Int/#Int ThreePiecesR GET+|]++instance Yesod master => YesodSubDispatch Subsite master where+    yesodSubDispatch ysre =+        f ysre+      where+        Subsite f = ysreGetSub ysre $ yreSite $ ysreParentEnv ysre
+ test/YesodCoreTest/ParamDefaultSplit/Data.hs view
@@ -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+|]
+ test/YesodCoreTest/ParamDefaultSplit/Runtime.hs view
@@ -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
+ test/YesodCoreTest/ParamFallthroughRuntime.hs view
@@ -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")
+ test/YesodCoreTest/ParamFocusSplit/Resources.hs view
@@ -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+|]
+ test/YesodCoreTest/ParamFocusSplit/Runtime.hs view
@@ -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
+ test/YesodCoreTest/ParamFocusSplit/SubR.hs view
@@ -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"
+ test/YesodCoreTest/ParamNestedNoFallthroughRuntime.hs view
@@ -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
+ test/YesodCoreTest/ParamNoExplicitArgs.hs view
@@ -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)
+ test/YesodCoreTest/ParamNoFallthroughRuntime.hs view
@@ -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
+ test/YesodCoreTest/ParamSubsite/Data.hs view
@@ -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
+ test/YesodCoreTest/ParamSubsite/InstanceRuntime.hs view
@@ -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
+ test/YesodCoreTest/ParamSubsite/SplitNested.hs view
@@ -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)
+ test/YesodCoreTest/ParamSubsite/SplitRuntime.hs view
@@ -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
+ test/YesodCoreTest/ParamTopLevelRuntime.hs view
@@ -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
+ test/YesodCoreTest/ParameterizedSite.hs view
@@ -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
+ test/YesodCoreTest/ParameterizedSite/Compat.hs view
@@ -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|+        <p>+            Stub+    |]
+ test/YesodCoreTest/ParameterizedSite/PolyAny.hs view
@@ -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|+        <p>+            Stub+    |]
+ test/YesodCoreTest/ParameterizedSite/PolyShow.hs view
@@ -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|+            <p>+                Stub #{show x}+        |]
+ test/YesodCoreTest/ParameterizedSite/SubRoute.hs view
@@ -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|+            <p>+                Stub #{show x} #{show key}+        |]++getAwayR :: SiteClass a => Key a -> HandlerFor (SubRoute a v) Html+getAwayR key1 = do+    SubRoute x <- liftHandler getYesod+    defaultLayout+        [whamlet|+            <p>+                Stub #{show x} #{show key1}+        |]
+ test/YesodCoreTest/ParameterizedSubData.hs view
@@ -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+|]
+ test/YesodCoreTest/ParameterizedSubDispatch.hs view
@@ -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
+ test/YesodCoreTest/ParameterizedSubDispatch/Data.hs view
@@ -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+|]
+ test/YesodCoreTest/ParameterizedSubDispatchRuntime.hs view
@@ -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
+ test/YesodCoreTest/ParameterizedSubDispatchRuntime/Data.hs view
@@ -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
+ test/YesodCoreTest/RawResponse.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module YesodCoreTest.RawResponse+    ( specs+    , Widget+    , resourcesApp+    ) where++import Yesod.Core+import Test.Hspec+import Network.Wai (responseStream)+import qualified Data.Conduit.List as CL+import qualified Data.ByteString.Char8 as S8+import Data.Conduit+import qualified Data.Conduit.Binary as CB+import Data.Char (toUpper)+import Data.Conduit.Network+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (race)+import Control.Monad.Trans.Resource (register)+import Data.IORef+import Network.HTTP.Types (status200)+import Network.Wai.Handler.Warp (testWithApplication)++mkYesod "App" [parseRoutes|+/ HomeR GET+/wai-stream WaiStreamR GET+/wai-app-stream WaiAppStreamR GET+|]++data App = App++instance Yesod App++getHomeR :: Handler ()+getHomeR = do+    ref <- liftIO $ newIORef (0 :: Int)+    _ <- register $ writeIORef ref 1+    sendRawResponse $ \src sink -> liftIO $ do+        val <- readIORef ref+        runConduit $ yield (S8.pack $ show val) .| sink+        runConduit $ src .| CL.map (S8.map toUpper) .| sink++getWaiStreamR :: Handler ()+getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do+    flush+    send "hello"+    flush+    send " world"++getWaiAppStreamR :: Handler ()+getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 [] $ \send flush -> do+    flush+    send "hello"+    flush+    send " world"++allowFiveSeconds :: IO a -> IO a+allowFiveSeconds = fmap (either id id) . race (threadDelay 5000000 >> error "timed out")++specs :: Spec+specs = do+    describe "RawResponse" $ do+        it "works" $ allowFiveSeconds $ testWithApplication (toWaiApp App) $ \port -> do+            runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do+                runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad+                runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO")+                runConduit $ yield "WORLd" .| appSink ad+                runConduit (appSource ad .| await) >>= (`shouldBe` Just "WORLD")++    let body req = allowFiveSeconds $ testWithApplication (toWaiApp App) $ \port -> do+            runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do+                runConduit $ yield req .| appSink ad+                runConduit $ appSource ad .| CB.lines .| do+                    let loop = do+                            x <- await+                            case x of+                                Nothing -> return ()+                                Just "\r" -> return ()+                                _ -> loop+                    loop++                    Just "0005\r" <- await+                    Just "hello\r" <- await++                    Just "0006\r" <- await+                    Just " world\r" <- await++                    return ()+    it "sendWaiResponse + responseStream" $ do+        body "GET /wai-stream HTTP/1.1\r\n\r\n"+    it "sendWaiApplication + responseStream" $ do+        body "GET /wai-app-stream HTTP/1.1\r\n\r\n"
test/YesodCoreTest/Redirect.hs view
@@ -1,17 +1,28 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-}-module YesodCoreTest.Redirect (specs, Widget) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} +module YesodCoreTest.Redirect+    ( specs+    , Widget+    , resourcesY+    ) where+ import YesodCoreTest.YesodTest-import Yesod.Handler (redirectWith)+import Yesod.Core.Handler (redirectWith, setEtag, setWeakEtag) import qualified Network.HTTP.Types as H  data Y = Y mkYesod "Y" [parseRoutes|-/ RootR GET+/ RootR GET POST /r301 R301 GET /r303 R303 GET /r307 R307 GET /rregular RRegular GET+/etag EtagR GET+/weak-etag WeakEtagR GET |] instance Yesod Y where approot = ApprootStatic "http://test" app :: Session () -> IO ()@@ -20,14 +31,24 @@ getRootR :: Handler () getRootR = return () -getR301, getR303, getR307, getRRegular :: Handler ()+postRootR :: Handler ()+postRootR = return ()++getR301, getR303, getR307, getRRegular, getEtagR, getWeakEtagR :: Handler () getR301 = redirectWith H.status301 RootR getR303 = redirectWith H.status303 RootR getR307 = redirectWith H.status307 RootR getRRegular = redirect RootR+getEtagR = setEtag "hello world"+getWeakEtagR = setWeakEtag "hello world"  specs :: Spec specs = describe "Redirect" $ do+    it "no redirect" $ app $ do+      res <- request defaultRequest { pathInfo = [], requestMethod = "POST" }+      assertStatus 200 res+      assertBodyContains "" res+     it "301 redirect" $ app $ do       res <- request defaultRequest { pathInfo = ["r301"] }       assertStatus 301 res@@ -45,7 +66,8 @@      it "303 redirect for regular, HTTP 1.1" $ app $ do       res <- request defaultRequest {-        pathInfo = ["rregular"]+        pathInfo = ["rregular"],+        httpVersion = H.http11       }       assertStatus 303 res       assertBodyContains "" res@@ -56,3 +78,60 @@       }       assertStatus 302 res       assertBodyContains "" res++    describe "etag" $ do+      it "no if-none-match" $ app $ do+        res <- request defaultRequest { pathInfo = ["etag"] }+        assertStatus 200 res+        assertHeader "etag" "\"hello world\"" res+      -- Note: this violates the RFC around ETag format, but is being left as is+      -- out of concerns that it might break existing users with misbehaving clients.+      it "single, unquoted if-none-match" $ app $ do+        res <- request defaultRequest+            { pathInfo = ["etag"]+            , requestHeaders = [("if-none-match", "hello world")]+            }+        assertStatus 304 res+      it "different if-none-match" $ app $ do+        res <- request defaultRequest+            { pathInfo = ["etag"]+            , requestHeaders = [("if-none-match", "hello world!")]+            }+        assertStatus 200 res+        assertHeader "etag" "\"hello world\"" res+      it "single, quoted if-none-match" $ app $ do+        res <- request defaultRequest+            { pathInfo = ["etag"]+            , requestHeaders = [("if-none-match", "\"hello world\"")]+            }+        assertStatus 304 res+      it "multiple quoted if-none-match" $ app $ do+        res <- request defaultRequest+            { pathInfo = ["etag"]+            , requestHeaders = [("if-none-match", "\"foo\", \"hello world\"")]+            }+        assertStatus 304 res+      it "ignore weak when provided normal etag" $ app $ do+        res <- request defaultRequest+            { pathInfo = ["etag"]+            , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")]+            }+        assertStatus 200 res+      it "weak etag" $ app $ do+        res <- request defaultRequest+            { pathInfo = ["weak-etag"]+            , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")]+            }+        assertStatus 304 res+      it "different if-none-match for weak etag" $ app $ do+        res <- request defaultRequest+            { pathInfo = ["weak-etag"]+            , requestHeaders = [("if-none-match", "W/\"foo\"")]+            }+        assertStatus 200 res+      it "ignore strong when expecting weak" $ app $ do+        res <- request defaultRequest+            { pathInfo = ["weak-etag"]+            , requestHeaders = [("if-none-match", "\"hello world\", W/\"foo\"")]+            }+        assertStatus 200 res
+ test/YesodCoreTest/RenderRouteSpec.hs view
@@ -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
+ test/YesodCoreTest/RenderRouteSpec/TH.hs view
@@ -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+
+ test/YesodCoreTest/Reps.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module YesodCoreTest.Reps+    ( specs+    , Widget+    , resourcesApp+    ) where++import Yesod.Core+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 Data.Maybe (fromJust)+import Data.Monoid (Endo (..))+import qualified Control.Monad.Trans.Writer    as Writer+import qualified Data.Set as Set++data App = App++mkYesod "App" [parseRoutes|+/     HomeR GET !home+/json JsonR GET+/parent/#Int ParentR:+    /#Text/child ChildR !child+|]++instance Yesod App++specialHtml :: IsString a => a+specialHtml = "text/html; charset=special"++getHomeR :: Handler TypedContent+getHomeR = selectRep $ do+    rep typeHtml "HTML"+    rep specialHtml "HTMLSPECIAL"+    rep typeXml "XML"+    rep typeJson "JSON"++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)]++handleChildR :: Int -> Text -> Handler ()+handleChildR _ _ = return ()++testRequest :: Int -- ^ http status code+            -> Request+            -> ByteString -- ^ expected body+            -> Spec+testRequest status req expected = it (S8.unpack $ fromJust $ lookup "Accept" $ requestHeaders req) $ do+    app <- toWaiApp App+    flip runSession app $ do+        sres <- request req+        assertStatus status sres+        assertBody expected sres++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)]+            }++specs :: Spec+specs = do+  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 $ ChildR "ignored") `shouldBe` Set.singleton "child"
test/YesodCoreTest/RequestBodySize.hs view
@@ -1,11 +1,19 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}-module YesodCoreTest.RequestBodySize (specs, Widget) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} +module YesodCoreTest.RequestBodySize+    ( specs+    , Widget+    , resourcesY+    ) where+ import Test.Hspec -import Yesod.Core hiding (Request)+import Yesod.Core  import Network.Wai import Network.Wai.Test@@ -29,7 +37,7 @@ |]  instance Yesod Y where-    maximumContentLength _ _ = 10+    maximumContentLength _ _ = Just 10  postPostR, postConsumeR, postPartialConsumeR, postUnusedR :: Handler RepPlain @@ -38,13 +46,11 @@     return $ RepPlain $ toContent $ T.concat val  postConsumeR = do-    req <- waiRequest-    body <- lift $ requestBody req $$ consume+    body <- runConduit $ rawRequestBody .| consume     return $ RepPlain $ toContent $ S.concat body  postPartialConsumeR = do-    req <- waiRequest-    body <- lift $ requestBody req $$ isolate 5 =$ consume+    body <- runConduit $ rawRequestBody .| isolate 5 .| consume     return $ RepPlain $ toContent $ S.concat body  postUnusedR = return $ RepPlain ""@@ -75,14 +81,18 @@                 then [("content-length", S8.pack $ show $ S.length body)]                 else []         , requestMethod = "POST"+        , requestBodyLength =+            if includeLength+                then KnownLength $ fromIntegral $ S.length body+                else ChunkedBody         } $ L.fromChunks $ map S.singleton $ S.unpack body  specs :: Spec specs = describe "Test.RequestBodySize" $ do     caseHelper "lookupPostParam- large" "post" "foobarbaz=bin" 413 413     caseHelper "lookupPostParam- small" "post" "foo=bin" 200 200-    caseHelper "consume- large" "consume" "this is longer than 10" 413 413-    caseHelper "consume- small" "consume" "smaller" 200 200+    caseHelper "total consume- large" "consume" "this is longer than 10" 413 413+    caseHelper "total consume- small" "consume" "smaller" 200 200     caseHelper "partial consume- large" "partial-consume" "this is longer than 10" 200 413     caseHelper "partial consume- small" "partial-consume" "smaller" 200 200     caseHelper "unused- large" "unused" "this is longer than 10" 200 413
+ test/YesodCoreTest/RuntimeHarness.hs view
@@ -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
+ test/YesodCoreTest/SplitSubsite/Data.hs view
@@ -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+|]
+ test/YesodCoreTest/SplitSubsite/NestedR.hs view
@@ -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)
+ test/YesodCoreTest/SplitSubsite/Runtime.hs view
@@ -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
+ test/YesodCoreTest/Ssl.hs view
@@ -0,0 +1,83 @@+{-# 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+import qualified YesodCoreTest.StubStrictSameSite as StrictSameSite+import qualified YesodCoreTest.StubUnsecured as Unsecured+import Yesod.Core+import Test.Hspec+import Network.Wai+import Network.Wai.Test+import qualified Data.ByteString.Char8 as C8+import qualified Web.Cookie as Cookie+import qualified Data.List as DL++type CookieSpec = Cookie.SetCookie -> Bool++type ResponseExpectation = SResponse -> Session ()++homeFixtureFor :: YesodDispatch a => a -> ResponseExpectation -> IO ()+homeFixtureFor app assertion = do+    wa <- toWaiApp app+    runSession (getHome >>= assertion) wa+  where+    getHome = request defaultRequest++cookieShouldSatisfy :: String -> CookieSpec -> ResponseExpectation+cookieShouldSatisfy name spec response =+    liftIO $+      case DL.filter matchesName $ cookiesIn response of+          [] -> expectationFailure $ DL.concat+            [ "Expected a cookie named "+            , name+            , " but none is set"+            ]+          [c] -> c `shouldSatisfy` spec+          _ -> expectationFailure $ DL.concat+            [ "Expected one cookie named "+            , name+            , " but found more than one"+            ]+  where+    matchesName c = (Cookie.setCookieName c) == C8.pack name+    cookiesIn r =+      DL.map+        (Cookie.parseSetCookie . snd)+        (DL.filter (("Set-Cookie" ==) . fst) $ simpleHeaders r)++sslOnlySpec :: Spec+sslOnlySpec = describe "A Yesod application with sslOnly on" $ do+    it "serves a Strict-Transport-Security header in all responses" $+        atHome $ assertHeader "Strict-Transport-Security"+                              "max-age=7200; includeSubDomains"+    it "sets the Secure flag on its session cookie" $+        atHome $ "_SESSION" `cookieShouldSatisfy` Cookie.setCookieSecure+  where+    atHome = homeFixtureFor Ssl.App++unsecSpec :: Spec+unsecSpec = describe "A Yesod application with sslOnly off" $ do+    it "never serves a Strict-Transport-Security header" $ do+        atHome $ assertNoHeader "Strict-Transport-Security"+    it "does not set the Secure flag on its session cookie" $ do+        atHome $ "_SESSION" `cookieShouldSatisfy` isNotSecure+  where+    atHome = homeFixtureFor Unsecured.App+    isNotSecure c = not $ Cookie.setCookieSecure c++sameSiteSpec :: Spec+sameSiteSpec = describe "A Yesod application" $ do+    it "can set a Lax SameSite option" $+        laxHome $ "_SESSION" `cookieShouldSatisfy` isLax+    it "can set a Strict SameSite option" $+        strictHome $ "_SESSION" `cookieShouldSatisfy` isStrict+  where+    laxHome = homeFixtureFor LaxSameSite.App+    strictHome = homeFixtureFor StrictSameSite.App+    isLax = (== Just Cookie.sameSiteLax) . Cookie.setCookieSameSite+    isStrict = (== Just Cookie.sameSiteStrict) . Cookie.setCookieSameSite
+ test/YesodCoreTest/Streaming.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}++module YesodCoreTest.Streaming (specs) where++import Yesod.Core+import Test.Hspec+import Network.Wai.Test+import Data.Text (Text)+import Data.ByteString (ByteString)++app :: LiteApp+app = liteApp $ dispatchTo $ respondSource typeHtml $ do+    sendChunk ("Hello " :: String)+    sendChunk ("World" :: ByteString)+    sendChunk ("!\n" :: Text)+    sendChunkHtml "<&>"++test :: String+     -> (SResponse -> Session ())+     -> Spec+test name f = it name $ do+    wapp <- toWaiApp app+    flip runSession wapp $ do+        sres <- request defaultRequest+        f sres++specs :: Spec+specs = describe "Streaming" $ do+    test "works" $ \sres -> do+        assertStatus 200 sres+        assertBody "Hello World!\n&lt;&amp;&gt;" sres
+ test/YesodCoreTest/StubLaxSameSite.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module YesodCoreTest.StubLaxSameSite+    ( App ( App )+    , Widget+    , resourcesApp+    ) where++import Yesod.Core+import qualified Web.ClientSession                  as CS++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET+|]++instance Yesod App where+    yesodMiddleware = defaultYesodMiddleware . (sslOnlyMiddleware 120)+    makeSessionBackend _ = laxSameSiteSessions $+        fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile++getHomeR :: Handler Html+getHomeR = defaultLayout+    [whamlet|+        <p>+            Welcome to my test application.+    |]
+ test/YesodCoreTest/StubSslOnly.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module YesodCoreTest.StubSslOnly+    ( App ( App )+    , Widget+    , resourcesApp+    ) where++import Yesod.Core+import qualified Web.ClientSession                  as CS++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET+|]++instance Yesod App where+    yesodMiddleware = defaultYesodMiddleware . (sslOnlyMiddleware 120)+    makeSessionBackend _ = sslOnlySessions $+        fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile++getHomeR :: Handler Html+getHomeR = defaultLayout+    [whamlet|+        <p>+            Welcome to my test application.+    |]
+ test/YesodCoreTest/StubStrictSameSite.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module YesodCoreTest.StubStrictSameSite+    ( App ( App )+    , Widget+    , resourcesApp+    ) where++import Yesod.Core+import qualified Web.ClientSession                  as CS++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET+|]++instance Yesod App where+    yesodMiddleware = defaultYesodMiddleware . (sslOnlyMiddleware 120)+    makeSessionBackend _ = strictSameSiteSessions $+        fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile++getHomeR :: Handler Html+getHomeR = defaultLayout+    [whamlet|+        <p>+            Welcome to my test application.+    |]
+ test/YesodCoreTest/StubUnsecured.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module YesodCoreTest.StubUnsecured+    ( App ( App )+    , Widget+    , resourcesApp+    ) where++import Yesod.Core++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET+|]++instance Yesod App++getHomeR :: Handler Html+getHomeR = defaultLayout+    [whamlet|+        <p>+            Welcome to my test application.+    |]
+ test/YesodCoreTest/SubSub.hs view
@@ -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
+ test/YesodCoreTest/SubSubData.hs view
@@ -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+|]
+ test/YesodCoreTest/SubsiteFallthrough/Data.hs view
@@ -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+|]
+ test/YesodCoreTest/SubsiteFallthrough/Nested.hs view
@@ -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)
+ test/YesodCoreTest/SubsiteFallthrough/Runtime.hs view
@@ -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
+ test/YesodCoreTest/SubsiteOptsFallthrough/Data.hs view
@@ -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+|]
+ test/YesodCoreTest/SubsiteOptsFallthrough/Runtime.hs view
@@ -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
test/YesodCoreTest/WaiSubsite.hs view
@@ -1,20 +1,41 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-}-module YesodCoreTest.WaiSubsite (specs, Widget) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} +module YesodCoreTest.WaiSubsite+    ( specs+    , Widget+    , resourcesY+    ) where+ import YesodCoreTest.YesodTest import Yesod.Core import qualified Network.HTTP.Types as H+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as B (concat)+import qualified Data.ByteString.Lazy.Char8 as B8 (pack) -myApp :: Application-myApp _ = return $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI"+myApp :: ByteString -> Application+myApp s _ f = f $ responseLBS H.status200 [("Content-type", "text/plain")] s  getApp :: a -> WaiSubsite-getApp _ = WaiSubsite myApp+getApp _ = WaiSubsite $ myApp "WAI" +getAppArgs :: a -> Int -> Int -> WaiSubsite+getAppArgs _ i j = WaiSubsite $ myApp $ B.concat ["WAI - ", B8.pack $ show i, " - ", B8.pack $ show j ]+ data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /sub WaiSubsiteR WaiSubsite getApp+/nested NestedR:+  /sub NestedWaiSubsiteR WaiSubsite getApp+/nestedargs/#Int NestedArgsR:+  /sub/#Int NestedArgsWaiSubsiteR WaiSubsite getAppArgs |]  instance Yesod Y@@ -36,3 +57,13 @@       res <- request defaultRequest { pathInfo = ["sub", "foo"] }       assertStatus 200 res       assertBodyContains "WAI" res++    it "nested subsite" $ app $ do+      res <- request defaultRequest { pathInfo = ["nested", "sub", "foo"] }+      assertStatus 200 res+      assertBodyContains "WAI" res++    it "nested subsite with arguments" $ app $ do+      res <- request defaultRequest { pathInfo = ["nestedargs", "1", "sub", "2", "foo"] }+      assertStatus 200 res+      assertBodyContains "WAI - 1 - 2" res
test/YesodCoreTest/Widget.hs view
@@ -1,15 +1,19 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}-module YesodCoreTest.Widget (widgetTest) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} -import Test.Hspec+module YesodCoreTest.Widget+    ( widgetTest+    , resourcesY+    ) where -import Yesod.Core hiding (Request)-import Text.Julius-import Text.Lucius-import Text.Hamlet+import Test.Hspec +import Yesod.Core import Network.Wai import Network.Wai.Test @@ -31,7 +35,7 @@ instance Yesod Y where     approot = ApprootStatic "http://test" -getRootR :: Handler RepHtml+getRootR :: Handler Html getRootR = defaultLayout $ toWidgetBody [julius|<not escaped>|]  getMultiR :: [String] -> Handler ()@@ -46,35 +50,22 @@     renderMessage a (_:xs) y = renderMessage a xs y     renderMessage a [] y = renderMessage a ["en"] y -getTowidgetR :: Handler RepHtml-getTowidgetR = defaultLayout $ do-    toWidget [julius|foo|] :: Widget-    toWidgetHead [julius|foo|]-    toWidgetBody [julius|foo|]--    toWidget [lucius|foo{bar:baz}|]-    toWidgetHead [lucius|foo{bar:baz}|]--    toWidget [hamlet|<foo>|]-    toWidgetHead [hamlet|<foo>|]-    toWidgetBody [hamlet|<foo>|]--getWhamletR :: Handler RepHtml+getWhamletR :: Handler Html getWhamletR = defaultLayout [whamlet|-$newline never-<h1>Test-<h2>@{WhamletR}-<h3>_{Goodbye}-<h3>_{MsgAnother}-^{embed}-|]+                    $newline never+                    <h1>Test+                    <h2>@{WhamletR}+                    <h3>_{Goodbye}+                    <h3>_{MsgAnother}+                    ^{embed}+                |]   where     embed = [whamlet|-$newline never-<h4>Embed-|]+                $newline never+                <h4>Embed+                |] -getAutoR :: Handler RepHtml+getAutoR :: Handler Html getAutoR = defaultLayout [whamlet| $newline never ^{someHtml}@@ -82,19 +73,37 @@   where     someHtml = [shamlet|somehtml|] -getJSHeadR :: Handler RepHtml+getJSHeadR :: Handler Html getJSHeadR = defaultLayout $ toWidgetHead [julius|alert("hello");|] +getTowidgetR :: Handler Html+getTowidgetR = defaultLayout $ do+    toWidget [julius|toWidget|] :: Widget+    toWidgetHead [julius|toHead|]+    toWidgetBody [julius|toBody|]++    toWidget [lucius|toWidget{bar:baz}|]+    toWidgetHead [lucius|toHead{bar:baz}|]++    toWidget [hamlet|<p>toWidget|]+    toWidgetHead [hamlet|<toHead>|]+    toWidgetBody [hamlet|<p>toBody|]+ widgetTest :: Spec widgetTest = describe "Test.Widget" $ do-      it "addJuliusBody" case_addJuliusBody-      it "whamlet" case_whamlet-      it "two letter lang codes" case_two_letter_lang-      it "automatically applies toWidget" case_auto-      it "toWidgetHead puts JS in head" case_jshead+  it "addJuliusBody" case_addJuliusBody+  it "whamlet" case_whamlet+  it "two letter lang codes" case_two_letter_lang+  it "automatically applies toWidget" case_auto+  it "toWidgetHead puts JS in head" case_jshead+  it "toWidget" $ runner $ do+    res <- request defaultRequest+        { pathInfo = ["towidget"]+        }+    assertBody "<!DOCTYPE html>\n<html><head><title></title><script>toHead</script><toHead></toHead>\n<style>toWidget{bar:baz}toHead{bar:baz}</style></head><body><script>toBody</script><p>toWidget</p>\n<p>toBody</p>\n<script>toWidget</script></body></html>" res  runner :: Session () -> IO ()-runner f = toWaiApp Y >>= runSession f+runner f = toWaiAppPlain Y >>= runSession f  case_addJuliusBody :: IO () case_addJuliusBody = runner $ do
test/YesodCoreTest/YesodTest.hs view
@@ -9,10 +9,10 @@   , module Test.Hspec ) where -import Yesod.Core hiding (Request)+import Yesod.Core import Network.Wai.Test import Network.Wai import Test.Hspec -yesod :: (YesodDispatch y y, Yesod y) => y -> Session a -> IO a+yesod :: YesodDispatch y => y -> Session a -> IO a yesod app f = toWaiApp app >>= runSession f
+ test/YesodCoreTest/ZeroPieceShadow/FallApp.hs view
@@ -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"
+ test/YesodCoreTest/ZeroPieceShadow/ShadowApp.hs view
@@ -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"
+ test/YesodCoreTest/ZeroPieceShadowRuntime.hs view
@@ -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")
+ test/fixtures/routes_with_line_continuations.yesodroutes view
@@ -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
yesod-core.cabal view
@@ -1,131 +1,383 @@ name:            yesod-core-version:         1.1.8.3+version:         1.7.0.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com> maintainer:      Michael Snoyman <michael@snoyman.com> synopsis:        Creation of type-safe, RESTful web applications.-description:-    Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving.-    .-    The Yesod documentation site <http://www.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and Persistent.+description:     API docs and the README are available at <http://www.stackage.org/package/yesod-core> category:        Web, Yesod stability:       Stable-cabal-version:   >= 1.8+cabal-version:   >= 1.10 build-type:      Simple homepage:        http://www.yesodweb.com/ extra-source-files:-  test.hs   test/YesodCoreTest.hs-  test/YesodCoreTest/Cache.hs-  test/YesodCoreTest/CleanPath.hs-  test/YesodCoreTest/ErrorHandling.hs-  test/YesodCoreTest/Exceptions.hs-  test/YesodCoreTest/InternalRequest.hs-  test/YesodCoreTest/JsLoader.hs+  test/YesodCoreTest/*.hs   test/YesodCoreTest/JsLoaderSites/Bottom.hs-  test/YesodCoreTest/JsLoaderSites/HeadAsync.hs-  test/YesodCoreTest/Links.hs-  test/YesodCoreTest/Media.hs-  test/YesodCoreTest/MediaData.hs-  test/YesodCoreTest/NoOverloadedStrings.hs-  test/YesodCoreTest/Redirect.hs-  test/YesodCoreTest/RequestBodySize.hs-  test/YesodCoreTest/WaiSubsite.hs-  test/YesodCoreTest/Widget.hs-  test/YesodCoreTest/YesodTest.hs   test/en.msg   test/test.hs--flag test-  description: Build the executable to run unit tests-  default: False+  test/fixtures/routes_with_line_continuations.yesodroutes+  ChangeLog.md+  README.md+  docs/split-route-compilation.md  library-    -- Work around a bug in cabal. Without this, wai-test doesn't get built and-    -- we have a missing dependency during --enable-tests builds.-    if flag(test)-        build-depends: wai-test+    default-language: Haskell2010+    hs-source-dirs: src -    build-depends:   base                  >= 4.3      && < 5-                   , time                  >= 1.1.4-                   , yesod-routes          >= 1.1      && < 1.2-                   , wai                   >= 1.3      && < 1.5-                   , wai-extra             >= 1.3      && < 1.4-                   , bytestring            >= 0.9.1.4-                   , text                  >= 0.7      && < 0.12-                   , template-haskell-                   , path-pieces           >= 0.1.2    && < 0.2-                   , hamlet                >= 1.1      && < 1.2-                   , shakespeare           >= 1.0      && < 1.1-                   , shakespeare-js        >= 1.0.2    && < 1.2-                   , shakespeare-css       >= 1.0      && < 1.1-                   , shakespeare-i18n      >= 1.0      && < 1.1-                   , blaze-builder         >= 0.2.1.4  && < 0.4-                   , transformers          >= 0.2.2    && < 0.4-                   , clientsession         >= 0.8-                   , random                >= 1.0.0.2  && < 1.1-                   , cereal                >= 0.3      && < 0.4-                   , old-locale            >= 1.0.0.2  && < 1.1-                   , failure               >= 0.2      && < 0.3+    build-depends:   base                  >= 4.11     && < 5+                   , aeson                 >= 1.0+                   , attoparsec-aeson      >= 2.1+                   , auto-update+                   , blaze-html            >= 0.5+                   , blaze-markup          >= 0.7.1+                   , bytestring            >= 0.10.2+                   , case-insensitive      >= 0.2+                   , cereal                >= 0.3+                   , clientsession         >= 0.9.1    && < 0.10+                   , conduit               >= 1.3+                   , conduit-extra                    , containers            >= 0.2-                   , monad-control         >= 0.3      && < 0.4-                   , transformers-base     >= 0.4-                   , cookie                >= 0.4      && < 0.5+                   , cookie                >= 0.4.3    && < 0.6+                   , data-default+                   , deepseq               >= 1.3+                   , encoding+                   , entropy+                   , fast-logger           >= 2.2                    , http-types            >= 0.7-                   , case-insensitive      >= 0.2+                   , memory+                   , monad-logger          >= 0.3.10   && < 0.4+                   , mtl                    , parsec                >= 2        && < 3.2-                   , directory             >= 1-                   , vector                >= 0.9      && < 0.11-                   , aeson                 >= 0.5-                   , fast-logger           >= 0.2-                   , monad-logger          >= 0.2.1    && < 0.4-                   , conduit               >= 0.5-                   , resourcet             >= 0.3      && < 0.5-                   , lifted-base           >= 0.1-                   , blaze-html            >= 0.5-                   , blaze-markup          >= 0.5.1+                   , path-pieces           >= 0.1.2    && < 0.3+                   , primitive             >= 0.6+                   , random                >= 1.0.0.2  && < 1.4+                   , resourcet             >= 1.2+                   , shakespeare           >= 2.0+                   , template-haskell      >= 2.13+                   , text                  >= 0.7+                   , th-compat             >= 0.1+                   , th-lift-instances     >= 0.1+                   , time                  >= 1.5+                   , transformers          >= 0.4+                   , unix-compat+                   , unliftio+                   , unordered-containers  >= 0.2+                   , vector                >= 0.9      && < 0.14+                   , wai                   >= 3.2+                   , wai-extra             >= 3.0.7+                   , wai-logger            >= 0.2+                   , warp                  >= 3.0.2+                   , word8 -    exposed-modules: Yesod.Content-                     Yesod.Core-                     Yesod.Dispatch-                     Yesod.Handler-                     Yesod.Request-                     Yesod.Widget-                     Yesod.Message-                     Yesod.Internal.TestApi-    other-modules:   Yesod.Internal-                     Yesod.Internal.Cache-                     Yesod.Internal.Core-                     Yesod.Internal.Session-                     Yesod.Internal.Request+    exposed-modules: Yesod.Core+                     Yesod.Core.Content+                     Yesod.Core.Dispatch+                     Yesod.Core.Handler+                     Yesod.Core.Json+                     Yesod.Core.Widget+                     Yesod.Core.Internal+                     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+                     Yesod.Core.Internal.Util+                     Yesod.Core.Internal.Response+                     Yesod.Core.Internal.Run+                     Yesod.Core.Internal.TH+                     Yesod.Core.Internal.LiteApp+                     Yesod.Core.Class.Yesod+                     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+                     Yesod.Routes.Class+                     Yesod.Routes.Parse+                     Yesod.Routes.Overlap+                     Yesod.Routes.TH.Dispatch+                     Yesod.Routes.TH.RenderRoute+                     Yesod.Routes.TH.ParseRoute+                     Yesod.Routes.TH.RouteAttrs+                     Yesod.Routes.TH.Internal+     ghc-options:     -Wall +    -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443+    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+                   Yesod.Routes.TH+                   Yesod.Routes.TH.Dispatch+                   Yesod.Routes.TH.ParseRoute+                   Yesod.Routes.TH.RenderRoute+                   Yesod.Routes.TH.RouteAttrs+                   Yesod.Routes.TH.Types+                   Yesod.Routes.TH.Internal+                   Route.FallthroughSpec+                   YesodCoreTest.RuntimeHarness+                   Route.RenderRouteSpec+                   Route.RouteAttrSpec+                   Route.DiscoveryModeSpec+                   Route.SubDispatchAritySpec+                   Route.DeepAritySpec+                   Route.DeepArityTypes+                   Route.InstanceProbeSpec+                   Route.InstanceProbeTypes+                   Route.InlineParseClausesSpec+                   Route.NestedParseClausesSpec+                   Route.PureQ+                   Route.FocusLeafConsSpec+                   Route.MissingFocusTargetSpec+                   Route.MissingFocusTargetTypes+                   YesodCoreTest.RenderRouteSpec+                   YesodCoreTest.RenderRouteSpec.TH++    -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443+    other-extensions:      TemplateHaskell++    build-depends: base < 5+                 , 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+                 , 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+                   YesodCoreTest.Links+                   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+                   YesodCoreTest.RequestBodySize+                   YesodCoreTest.Ssl+                   YesodCoreTest.Streaming+                   YesodCoreTest.StubLaxSameSite+                   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+     cpp-options:   -DTEST-    build-depends: base-                  ,hspec >= 1.3-                  ,wai-test-                  ,wai-                  ,yesod-core-                  ,bytestring-                  ,hamlet-                  ,shakespeare-css-                  ,shakespeare-js-                  ,text-                  ,http-types-                  , random-                  , blaze-builder-                  ,HUnit-                  ,QuickCheck >= 2 && < 3-                  ,transformers+    if os(windows)+        cpp-options: -DWINDOWS+    build-depends:  base >= 4.11 && < 5+                  , async+                  , bytestring+                  , clientsession                   , conduit-    ghc-options:     -Wall+                  , conduit-extra+                  , containers+                  , cookie >= 0.4.1    && < 0.6+                  , data-default+                  , encoding+                  , hspec >= 1.3+                  , hspec-expectations+                  , http-types+                  , network+                  , random+                  , resourcet+                  , shakespeare+                  , streaming-commons+                  , template-haskell+                  , text+                  , transformers+                  , unliftio+                  , unordered-containers+                  , path-pieces+                  , mtl+                  , time+                  , cereal+                  , monad-logger+                  , deepseq+                  , blaze-html+                  , aeson+                  , primitive+                  , case-insensitive+                  , wai-logger+                  , memory+                  , unix-compat+                  , auto-update+                  , vector+                  , word8+                  , blaze-markup+                  , fast-logger+                  , parsec+                  , wai >= 3.0+                  , entropy+                  , attoparsec-aeson+                  , wai-extra+                  , warp+                  , th-lift-instances+                  , yesod-core+    -- NB: this behavioral suite depends on the *packaged* yesod-core library+    -- (no `src` on hs-source-dirs), so it compiles against the real+    -- exposed/hidden module boundary. That is what catches API-exposure+    -- regressions (a module that downstream consumers cannot import). The+    -- pure-codegen suite `test-routes` keeps `src` on hs-source-dirs because it+    -- legitimately needs internal modules (e.g. Yesod.Routes.TH.RenderRoute,+    -- Yesod.Routes.Class) for compile-time codegen assertions.+    ghc-options:     -Wall -threaded+    other-extensions: TemplateHaskell++benchmark widgets+    default-language: Haskell2010+    type: exitcode-stdio-1.0+    hs-source-dirs: bench+    build-depends:  base < 5+                  , blaze-html+                  , bytestring+                  , gauge+                  , shakespeare+                  , text+    main-is:        widget.hs+    ghc-options:    -Wall -O2  source-repository head   type:     git