Actually export the new options (#1825)

* actually export the new options

* bump version number, update changelog

.azure/azure-linux-template.yml

@@ -1,25 +0,0 @@
-jobs:
-- job: ${{ parameters.name }}
-  timeoutInMinutes: 180
-  pool:
-    vmImage: ${{ parameters.vmImage }}
-  strategy:
-    matrix:
-      GHC 8.2:
-        ARGS: "--resolver lts-11"
-      GHC 8.4:
-        ARGS: "--resolver lts-12"
-      GHC 8.6:
-        ARGS: "--resolver lts-14"
-      GHC 8.8:
-        ARGS: "--resolver lts-15"
-  steps:
-  - script: |
-      export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
-      export PATH=$HOME/.local/bin:$PATH
-      mkdir -p ~/.local/bin
-      curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
-      stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
-    env:
-      OS_NAME: ${{ parameters.os }}
-    displayName: 'Build and test'

.azure/azure-osx-template.yml

@@ -1,25 +0,0 @@
-jobs:
-- job: ${{ parameters.name }}
-  timeoutInMinutes: 120
-  pool:
-    vmImage: ${{ parameters.vmImage }}
-  strategy:
-    matrix:
-      GHC 8.2:
-        ARGS: "--resolver lts-11"
-      GHC 8.4:
-        ARGS: "--resolver lts-12"
-      GHC 8.6:
-        ARGS: "--resolver lts-14"
-      GHC 8.8:
-        ARGS: "--resolver lts-15"
-  steps:
-  - script: |
-      export PATH=$HOME/.local/bin:$PATH
-      export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
-      mkdir -p ~/.local/bin
-      curl -skL https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;
-      stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
-    env:
-      OS_NAME: ${{ parameters.os }}
-    displayName: 'Build and test'

.azure/azure-pipelines.yml

@@ -1,30 +0,0 @@
-# This is the complex Azure configuration, which is intended for use
-# on open source libraries which need compatibility across multiple GHC
-# versions, must work with cabal-install, and should be
-# cross-platform. For more information and other options, see:
-#
-# https://docs.haskellstack.org/en/stable/azure_ci/
-#
-# Copy these contents into the root directory of your Github project in a file
-# named azure-pipelines.yml
-#
-# For better organization, you split various jobs into seprate parts
-# and each of them are controlled via individual file.
-jobs:
-- template: azure-linux-template.yml
-  parameters:
-    name: Linux
-    vmImage: ubuntu-latest
-    os: linux
-
-- template: azure-osx-template.yml
-  parameters:
-    name: macOS
-    vmImage: macOS-latest
-    os: osx
-
-- template: azure-windows-template.yml
-  parameters:
-   name: Windows
-   vmImage: windows-latest
-   os: windows

.azure/azure-windows-template.yml

@@ -1,22 +0,0 @@
-jobs:
-- job: ${{ parameters.name }}
-  timeoutInMinutes: 120
-  pool:
-    vmImage: ${{ parameters.vmImage }}
-  strategy:
-    matrix:
-      GHC 8.2:
-        ARGS: "--resolver lts-11"
-      GHC 8.4:
-        ARGS: "--resolver lts-12"
-      GHC 8.6:
-        ARGS: "--resolver lts-14"
-  steps:
-  - bash: |
-      export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
-      curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip
-      unzip -o /usr/bin/stack.zip -d /usr/bin/
-      stack $ARGS test --bench --no-run-benchmarks
-    env:
-      OS_NAME: ${{ parameters.os }}
-    displayName: 'Build and test'

.github/workflows/tests.yml

@@ -0,0 +1,56 @@
+name: Tests
+
+on:
+    pull_request:
+    push:
+        branches:
+        - master
+
+jobs:
+  build:
+    name: CI
+    runs-on: ${{ matrix.os }}
+    strategy:
+      fail-fast: false
+      matrix:
+        os: [ubuntu-latest, macos-latest, windows-latest]
+        args:
+        #- "--resolver nightly"
+        - "--resolver nightly-2022-02-11"
+        - "--resolver lts-18"
+        - "--resolver lts-16"
+        - "--resolver lts-14"
+        - "--resolver lts-12"
+        - "--resolver lts-11"
+        # Bugs in GHC make it crash too often to be worth running
+        exclude:
+          - os: windows-latest
+            args: "--resolver nightly"
+          - os: macos-latest
+            args: "--resolver lts-16"
+          - os: macos-latest
+            args: "--resolver lts-14"
+          - os: macos-latest
+            args: "--resolver lts-12"
+          - os: macos-latest
+            args: "--resolver lts-11"
+
+    steps:
+      - name: Clone project
+        uses: actions/checkout@v2
+
+# Getting weird OS X errors...
+#      - name: Cache dependencies
+#        uses: actions/cache@v1
+#        with:
+#          path: ~/.stack
+#          key: ${{ runner.os }}-${{ matrix.resolver }}-${{ hashFiles('stack.yaml') }}
+#          restore-keys: |
+#            ${{ runner.os }}-${{ matrix.resolver }}-
+
+      - name: Build and run tests
+        shell: bash
+        run: |
+            set -ex
+            stack --version
+            stack test --fast --no-terminal ${{ matrix.args }}

.gitignore

@@ -25,3 +25,5 @@ tarballs/
 
 # OS X
 .DS_Store
+*.yaml.lock
+dist-newstyle/

README.md

@@ -1,4 +1,4 @@
-[![Build Status](https://dev.azure.com/yesodweb/yesod/_apis/build/status/yesodweb.yesod?branchName=master)](https://dev.azure.com/yesodweb/yesod/_build/latest?definitionId=3&branchName=master)
+![Tests](https://github.com/yesodweb/yesod/workflows/Tests/badge.svg)
 
 # Yesod Web Framework
 

cabal.project

@@ -0,0 +1,15 @@
+packages:
+  yesod-core
+  yesod-static
+  yesod-persistent
+  yesod-newsfeed
+  yesod-form
+  yesod-form-multi
+  yesod-auth
+  yesod-auth-oauth
+  yesod-sitemap
+  yesod-test
+  yesod-bin
+  yesod
+  yesod-eventsource
+  yesod-websockets

demo/subsite/WikiRoutes.hs

@@ -21,7 +21,7 @@ data Wiki = Wiki
     }
 
 -- | A typeclass that all master sites that want a Wiki must implement. A
--- master must be able to render form messages, as we use yesod-forms for
+-- master must be able to render form messages, as we use yesod-form for
 -- processing user input.
 class (RenderMessage master FormMessage, Yesod master) => YesodWiki master where
     -- | Write protection. By default, no protection.

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-15.5
+resolver: lts-18.3
 packages:
 - ./yesod-core
 - ./yesod-static
@@ -14,3 +14,6 @@ packages:
 - ./yesod
 - ./yesod-eventsource
 - ./yesod-websockets
+
+extra-deps:
+- attoparsec-aeson-2.1.0.0

stack.yaml.lock

@@ -3,10 +3,17 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/lock_files
 
-packages: []
+packages:
+- completed:
+    hackage: attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
+    pantry-tree:
+      sha256: 294c3a8a19a7ddad58097e18c624c6b34894b3c4a4cc490759cb31d842db242a
+      size: 114
+  original:
+    hackage: attoparsec-aeson-2.1.0.0
 snapshots:
 - completed:
-    size: 491372
+    sha256: 694573e96dca34db5636edb1fe6c96bb233ca0f9fb96c1ead1671cdfa9bd73e9
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/5.yaml
+    size: 585603
-    sha256: 1b549cfff328040c382a70a84a2087aac8dab6d778bf92f32a93a771a1980dfc
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/3.yaml
-  original: lts-15.5
+  original: lts-18.3

yesod-auth-oauth/ChangeLog.md

@@ -1,3 +1,13 @@
+# ChangeLog for yesod-auth-oauth
+
+## 1.6.1
+
+* Allow newer GHC
+
+## 1.6.0.3
+
+* Allow yesod-form 1.7
+
 ## 1.6.0.2
 
 * Remove unnecessary deriving of Typeable

yesod-auth-oauth/Yesod/Auth/OAuth.hs

@@ -18,7 +18,6 @@ import           Control.Applicative      as A ((<$>), (<*>))
 import           Control.Arrow            ((***))
 import           UnliftIO.Exception
 import           Control.Monad.IO.Class
-import           UnliftIO                 (MonadUnliftIO)
 import           Data.ByteString          (ByteString)
 import           Data.Maybe
 import           Data.Text                (Text)
@@ -53,14 +52,9 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
     oauthSessionName = "__oauth_token_secret"
 
     dispatch
-      :: ( MonadHandler m
+      :: Text
-         , master ~ HandlerSite m
-         , Auth ~ SubHandlerSite m
-         , MonadUnliftIO m
-         )
-      => Text
       -> [Text]
-      -> m TypedContent
+      -> AuthHandler master TypedContent
     dispatch "GET" ["forward"] = do
         render <- getUrlRender
         tm <- getRouteToParent

yesod-auth-oauth/yesod-auth-oauth.cabal

@@ -1,5 +1,6 @@
+cabal-version:   >= 1.10
 name:            yesod-auth-oauth
-version:         1.6.0.2
+version:         1.6.1
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
@@ -7,21 +8,21 @@ maintainer:      Michael Litchard
 synopsis:        OAuth Authentication for Yesod.
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-auth-oauth>
 extra-source-files: README.md ChangeLog.md
 
 library
-    build-depends:   authenticate-oauth      >= 1.5       && < 1.7
+    default-language: Haskell2010
+    build-depends:   authenticate-oauth      >= 1.5       && < 1.8
                    , base                    >= 4.10      && < 5
                    , bytestring              >= 0.9.1.4
                    , text                    >= 0.7
                    , unliftio
                    , yesod-auth              >= 1.6       && < 1.7
                    , yesod-core              >= 1.6       && < 1.7
-                   , yesod-form              >= 1.6       && < 1.7
+                   , yesod-form              >= 1.6       && < 1.8
     exposed-modules: Yesod.Auth.OAuth
     ghc-options:     -Wall
 

yesod-auth/ChangeLog.md

@@ -1,5 +1,37 @@
 # ChangeLog for yesod-auth
 
+## 1.6.11.2
+
+* Add support for aeson 2.2 [#1820](https://github.com/yesodweb/yesod/pull/1820)
+
+## 1.6.11.1
+
+* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
+
+## 1.6.11
+
+* Add support for aeson 2
+
+## 1.6.10.5
+
+* Fix German translations of AuthMessage [#1741](https://github.com/yesodweb/yesod/pull/1741)
+
+## 1.6.10.4
+
+* Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737)
+
+## 1.6.10.3
+
+* Relax bounds for yesod-form 1.7
+
+## 1.6.10.2
+
+* Relax bounds for persistent 2.12
+
+## 1.6.10.1
+
+* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)
+
 ## 1.6.10
 
 * Updated `AuthMessage` data type in `Yesod.Auth.Message` to accommodate registration flow where password is supplied initially: deprecated `AddressVerified` and split into `EmailVerifiedChangePass` and `EmailVerified`

yesod-auth/README.md

@@ -6,6 +6,7 @@ BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available
 from Hackage as well. If you've written such an add-on, please notify me so
 that it can be added to this description.
 
+* [yesod-auth-oauth2](https://hackage.haskell.org/package/yesod-auth-oauth2): Library to authenticate with OAuth 2.0.
 * [yesod-auth-account](http://hackage.haskell.org/package/yesod-auth-account): An account authentication plugin for Yesod
 * [yesod-auth-hashdb](http://www.stackage.org/package/yesod-auth-hashdb): The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security.
-* [yesod-auth-bcrypt](https://github.com/ollieh/yesod-auth-bcrypt/): An alternative to the HashDB module.
+* [yesod-auth-bcrypt](https://hackage.haskell.org/package/yesod-auth-bcrypt): An alternative to the HashDB module.

yesod-auth/Yesod/Auth.hs

@@ -52,7 +52,6 @@ import Control.Monad.Trans.Maybe
 import UnliftIO                      (withRunInIO, MonadUnliftIO)
 
 import Yesod.Auth.Routes
-import Data.Aeson hiding (json)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
 import           Data.Text (Text)
@@ -74,6 +73,7 @@ import Control.Exception (Exception)
 import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
 import qualified Control.Monad.Trans.Writer    as Writer
 import Control.Monad (void)
+import Data.Kind (Type)
 
 type AuthRoute = Route Auth
 
@@ -452,7 +452,7 @@ $nothing
     <p>Not logged in.
 |]
     jsonCreds creds =
-        Object $ Map.fromList
+        toJSON $ Map.fromList
             [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
             ]
 
@@ -533,7 +533,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
     -- > AuthEntity MySite ~ User
     --
     -- @since 1.2.0
-    type AuthEntity master :: *
+    type AuthEntity master :: Type
     type AuthEntity master = KeyEntity (AuthId master)
 
     getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)

yesod-auth/Yesod/Auth/Dummy.hs

@@ -1,8 +1,9 @@
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
 -- | Provides a dummy authentication module that simply lets a user specify
 -- their identifier. This is not intended for real world use, just for
 -- testing. This plugin supports form submissions via JSON (since 1.6.8).
@@ -35,12 +36,12 @@ module Yesod.Auth.Dummy
     ( authDummy
     ) where
 
-import Yesod.Auth
+import           Data.Aeson.Types (Parser, Result (..))
-import Yesod.Form (runInputPost, textField, ireq)
-import Yesod.Core
-import Data.Text (Text)
-import Data.Aeson.Types (Result(..), Parser)
 import qualified Data.Aeson.Types as A (parseEither, withObject)
+import           Data.Text        (Text)
+import           Yesod.Auth
+import           Yesod.Core
+import           Yesod.Form       (ireq, runInputPost, textField)
 
 identParser :: Value -> Parser Text
 identParser = A.withObject "Ident" (.: "ident")
@@ -49,6 +50,7 @@ authDummy :: YesodAuth m => AuthPlugin m
 authDummy =
     AuthPlugin "dummy" dispatch login
   where
+    dispatch :: Text -> [Text] -> AuthHandler m TypedContent
     dispatch "POST" [] = do
         (jsonResult :: Result Value) <- parseCheckJsonBody
         eIdent <- case jsonResult of

yesod-auth/Yesod/Auth/Email.hs

@@ -117,28 +117,30 @@ module Yesod.Auth.Email
     , defaultRegisterHelper
     ) where
 
-import           Yesod.Auth
+import           Control.Applicative           ((<$>), (<*>))
-import qualified Yesod.Auth.Message       as Msg
+import qualified Crypto.Hash                   as H
-import           Yesod.Core
+import qualified Crypto.Nonce                  as Nonce
-import           Yesod.Form
+import           Data.Aeson.Types              (Parser, Result (..), parseMaybe,
-import qualified Yesod.Auth.Util.PasswordStore as PS
+                                                withObject, (.:?))
-import           Control.Applicative      ((<$>), (<*>))
+import           Data.ByteArray                (convert)
-import qualified Crypto.Hash              as H
+import           Data.ByteString.Base16        as B16
-import qualified Crypto.Nonce             as Nonce
+import           Data.Maybe                    (isJust)
-import           Data.ByteString.Base16   as B16
+import           Data.Text                     (Text)
-import           Data.Text                (Text)
+import qualified Data.Text                     as T
-import qualified Data.Text                as TS
+import qualified Data.Text                     as TS
-import qualified Data.Text                as T
+import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8)
-import           Data.Text.Encoding       (decodeUtf8With, encodeUtf8)
+import qualified Data.Text.Encoding            as TE
-import qualified Data.Text.Encoding       as TE
+import           Data.Text.Encoding.Error      (lenientDecode)
-import           Data.Text.Encoding.Error (lenientDecode)
+import           Data.Time                     (addUTCTime, getCurrentTime)
-import           Data.Time                (addUTCTime, getCurrentTime)
+import           Safe                          (readMay)
-import           Safe                     (readMay)
+import           System.IO.Unsafe              (unsafePerformIO)
-import           System.IO.Unsafe         (unsafePerformIO)
 import qualified Text.Email.Validate
-import           Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
+import           Yesod.Auth
-import           Data.Maybe (isJust)
+import qualified Yesod.Auth.Message            as Msg
-import Data.ByteArray (convert)
+import qualified Yesod.Auth.Util.PasswordStore as PS
+import           Yesod.Core
+import           Yesod.Core.Types              (TypedContent (TypedContent))
+import           Yesod.Form
 
 loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
 loginR = PluginR "email" ["login"]
@@ -240,7 +242,7 @@ class ( YesodAuth site
     --
     -- @since 1.4.20
     hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
-    hashAndSaltPassword = liftIO . saltPass
+    hashAndSaltPassword password = liftIO $ saltPass password
 
     -- | Verify a password matches the stored password for the given account.
     --
@@ -432,13 +434,14 @@ authEmail :: (YesodAuthEmail m) => AuthPlugin m
 authEmail =
     AuthPlugin "email" dispatch emailLoginHandler
   where
+    dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent
     dispatch "GET" ["register"] = getRegisterR >>= sendResponse
     dispatch "POST" ["register"] = postRegisterR >>= sendResponse
     dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse
     dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse
     dispatch "GET" ["verify", eid, verkey] =
         case fromPathPiece eid of
-            Nothing -> notFound
+            Nothing   -> notFound
             Just eid' -> getVerifyR eid' verkey False >>= sendResponse
     dispatch "GET" ["verify", eid, verkey, hasSetPass] =
         case fromPathPiece eid of
@@ -485,13 +488,13 @@ defaultEmailLoginHandler toParent = do
         let userRes = UserLoginForm Control.Applicative.<$> emailRes
                                     Control.Applicative.<*> passwordRes
         let widget = do
-            [whamlet|
+              [whamlet|
-                #{extra}
+                  #{extra}
-                <div>
+                  <div>
-                    ^{fvInput emailView}
+                      ^{fvInput emailView}
-                <div>
+                  <div>
-                    ^{fvInput passwordView}
+                      ^{fvInput passwordView}
-            |]
+              |]
 
         return (userRes, widget)
     emailSettings emailMsg = do
@@ -545,11 +548,11 @@ defaultRegisterHandler = do
 
             let userRes = UserForm <$> emailRes
             let widget = do
-                [whamlet|
+                  [whamlet|
-                    #{extra}
+                      #{extra}
-                    ^{fvLabel emailView}
+                      ^{fvLabel emailView}
-                    ^{fvInput emailView}
+                      ^{fvInput emailView}
-                |]
+                  |]
 
             return (userRes, widget)
 
@@ -576,7 +579,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                  _ -> do
                      (creds :: Result Value) <- parseCheckJsonBody
                      return $ case creds of
-                                  Error _ -> Nothing
+                                  Error _     -> Nothing
                                   Success val -> parseMaybe parseRegister val
 
     let eidentifier = case creds of
@@ -589,7 +592,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
 
     let mpass = case (forgotPassword, creds) of
                     (False, Just (_, mp)) -> mp
-                    _ -> Nothing
+                    _                     -> Nothing
 
     case eidentifier of
       Left failMsg -> loginErrorMessageI dest failMsg
@@ -620,7 +623,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                     then sendConfirmationEmail creds
                     else case emailPreviouslyRegisteredResponse identifier of
                       Just response -> response
-                      Nothing -> sendConfirmationEmail creds
+                      Nothing       -> sendConfirmationEmail creds
               where sendConfirmationEmail (lid, _, verKey, email) = do
                       render <- getUrlRender
                       tp <- getRouteToParent
@@ -659,11 +662,11 @@ defaultForgotPasswordHandler = do
 
         let forgotPasswordRes = ForgotPasswordForm <$> emailRes
         let widget = do
-            [whamlet|
+              [whamlet|
-                #{extra}
+                  #{extra}
-                ^{fvLabel emailView}
+                  ^{fvLabel emailView}
-                ^{fvInput emailView}
+                  ^{fvInput emailView}
-            |]
+              |]
         return (forgotPasswordRes, widget)
 
     emailSettings =
@@ -739,7 +742,7 @@ postLoginR = do
                      _ -> do
                        (creds :: Result Value) <- parseCheckJsonBody
                        case creds of
-                         Error _ -> return Nothing
+                         Error _     -> return Nothing
                          Success val -> return $ parseMaybe parseCreds val
 
     case midentifier of
@@ -779,8 +782,8 @@ getPasswordR = do
     maid <- maybeAuthId
     case maid of
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-        Just _ -> do
+        Just aid -> do
-            needOld <- maybe (return True) needOldPassword maid
+            needOld <- needOldPassword aid
             setPasswordHandler needOld
 
 -- | Default implementation of 'setPasswordHandler'.
@@ -808,29 +811,29 @@ defaultSetPasswordHandler needOld = do
 
         let passwordFormRes = PasswordForm <$> currentPasswordRes <*> newPasswordRes <*> confirmPasswordRes
         let widget = do
-            [whamlet|
+              [whamlet|
-                #{extra}
+                  #{extra}
-                <table>
+                  <table>
-                    $if needOld
+                      $if needOld
-                        <tr>
+                          <tr>
-                            <th>
+                              <th>
-                                ^{fvLabel currentPasswordView}
+                                  ^{fvLabel currentPasswordView}
-                            <td>
+                              <td>
-                                ^{fvInput currentPasswordView}
+                                  ^{fvInput currentPasswordView}
-                    <tr>
+                      <tr>
-                        <th>
+                          <th>
-                            ^{fvLabel newPasswordView}
+                              ^{fvLabel newPasswordView}
-                        <td>
+                          <td>
-                            ^{fvInput newPasswordView}
+                              ^{fvInput newPasswordView}
-                    <tr>
+                      <tr>
-                        <th>
+                          <th>
-                            ^{fvLabel confirmPasswordView}
+                              ^{fvLabel confirmPasswordView}
-                        <td>
+                          <td>
-                            ^{fvInput confirmPasswordView}
+                              ^{fvInput confirmPasswordView}
-                    <tr>
+                      <tr>
-                        <td colspan="2">
+                          <td colspan="2">
-                            <input type=submit value=_{Msg.SetPassTitle}>
+                              <input type=submit value=_{Msg.SetPassTitle}>
-            |]
+              |]
 
         return (passwordFormRes, widget)
     currentPasswordSettings =
@@ -870,7 +873,7 @@ postPasswordR = do
     maid <- maybeAuthId
     (creds :: Result Value) <- parseCheckJsonBody
     let jcreds = case creds of
-                   Error _ -> Nothing
+                   Error _     -> Nothing
                    Success val -> parseMaybe parsePassword val
     let doJsonParsing = isJust jcreds
     case maid of
@@ -882,7 +885,7 @@ postPasswordR = do
                 res <- runInputPostResult $ ireq textField "current"
                 let fcurrent = case res of
                                  FormSuccess currentPass -> Just currentPass
-                                 _ -> Nothing
+                                 _                       -> Nothing
                 let current = if doJsonParsing
                               then getThird jcreds
                               else fcurrent
@@ -901,9 +904,9 @@ postPasswordR = do
   where
     msgOk = Msg.PassUpdated
     getThird (Just (_,_,t)) = t
-    getThird Nothing = Nothing
+    getThird Nothing        = Nothing
     getNewConfirm (Just (a,b,_)) = Just (a,b)
-    getNewConfirm _ = Nothing
+    getNewConfirm _              = Nothing
     confirmPassword aid tm jcreds = do
         res <- runInputPostResult $ (,)
             <$> ireq textField "new"
@@ -912,7 +915,7 @@ postPasswordR = do
                     then getNewConfirm jcreds
                     else case res of
                            FormSuccess res' -> Just res'
-                           _ -> Nothing
+                           _                -> Nothing
         case creds of
           Nothing -> loginErrorMessageI setpassR Msg.PassMismatch
           Just (new, confirm) ->

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -53,55 +53,61 @@ module Yesod.Auth.GoogleEmail2
     , pid
     ) where
 
-import           Yesod.Auth               (Auth, AuthPlugin (AuthPlugin),
+import           Yesod.Auth                  (Auth, AuthHandler,
-                                           AuthRoute, Creds (Creds),
+                                              AuthPlugin (AuthPlugin),
-                                           Route (PluginR), YesodAuth,
+                                              AuthRoute, Creds (Creds),
-                                           runHttpRequest, setCredsRedirect,
+                                              Route (PluginR), YesodAuth,
-                                           logoutDest, AuthHandler)
+                                              logoutDest, runHttpRequest,
-import qualified Yesod.Auth.Message       as Msg
+                                              setCredsRedirect)
-import           Yesod.Core               (HandlerSite, MonadHandler,
+import qualified Yesod.Auth.Message          as Msg
-                                           TypedContent, getRouteToParent,
+import           Yesod.Core                  (HandlerSite, MonadHandler,
-                                           getUrlRender, invalidArgs,
+                                              TypedContent, addMessage,
-                                           liftIO, lookupGetParam,
+                                              getRouteToParent, getUrlRender,
-                                           lookupSession, notFound, redirect,
+                                              getYesod, invalidArgs, liftIO,
-                                           setSession, whamlet, (.:),
+                                              liftSubHandler, lookupGetParam,
-                                           addMessage, getYesod,
+                                              lookupSession, notFound, redirect,
-                                           toHtml, liftSubHandler)
+                                              setSession, toHtml, whamlet, (.:))
 
 
-import           Blaze.ByteString.Builder (fromByteString, toByteString)
+import           Blaze.ByteString.Builder    (fromByteString, toByteString)
-import           Control.Applicative      ((<$>), (<*>))
+import           Control.Applicative         ((<$>), (<*>))
-import           Control.Arrow            (second)
+import           Control.Arrow               (second)
-import           Control.Monad            (unless, when)
+import           Control.Monad               (unless, when)
-import           Control.Monad.IO.Class   (MonadIO)
+import           Control.Monad.IO.Class      (MonadIO)
-import qualified Crypto.Nonce             as Nonce
+import qualified Crypto.Nonce                as Nonce
-import           Data.Aeson               ((.:?))
+import           Data.Aeson                  ((.:?))
-import qualified Data.Aeson               as A
+import qualified Data.Aeson                  as A
 #if MIN_VERSION_aeson(1,0,0)
-import qualified Data.Aeson.Text          as A
+import qualified Data.Aeson.Text             as A
 #else
-import qualified Data.Aeson.Encode        as A
+import qualified Data.Aeson.Encode           as A
 #endif
-import           Data.Aeson.Parser        (json')
+import           Data.Aeson.Parser           (json')
-import           Data.Aeson.Types         (FromJSON (parseJSON), parseEither,
+import           Data.Aeson.Types            (FromJSON (parseJSON), parseEither,
-                                           parseMaybe, withObject, withText)
+                                              parseMaybe, withObject, withText)
 import           Data.Conduit
-import           Data.Conduit.Attoparsec  (sinkParser)
+import           Data.Conduit.Attoparsec     (sinkParser)
-import qualified Data.HashMap.Strict      as M
+import           Data.Maybe                  (fromMaybe)
-import           Data.Maybe               (fromMaybe)
+import           Data.Monoid                 (mappend)
-import           Data.Monoid              (mappend)
+import           Data.Text                   (Text)
-import           Data.Text                (Text)
+import qualified Data.Text                   as T
-import qualified Data.Text                as T
+import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)
-import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)
+import qualified Data.Text.Lazy              as TL
-import qualified Data.Text.Lazy           as TL
+import qualified Data.Text.Lazy.Builder      as TL
-import qualified Data.Text.Lazy.Builder   as TL
+import           Network.HTTP.Client         (Manager, requestHeaders,
-import           Network.HTTP.Client      (Manager, requestHeaders,
+                                              responseBody, urlEncodedBody)
-                                           responseBody, urlEncodedBody)
+import qualified Network.HTTP.Client         as HTTP
-import qualified Network.HTTP.Client      as HTTP
 import           Network.HTTP.Client.Conduit (Request, bodyReaderSource)
-import           Network.HTTP.Conduit (http)
+import           Network.HTTP.Conduit        (http)
-import           Network.HTTP.Types       (renderQueryText)
+import           Network.HTTP.Types          (renderQueryText)
-import           System.IO.Unsafe         (unsafePerformIO)
+import           System.IO.Unsafe            (unsafePerformIO)
+
+#if MIN_VERSION_aeson(2, 0, 0)
+import qualified Data.Aeson.Key
+import qualified Data.Aeson.KeyMap
+#else
+import qualified Data.HashMap.Strict         as M
+#endif
 
 
 -- | Plugin identifier. This is used to identify the plugin used for
@@ -239,7 +245,7 @@ authPlugin storeToken clientID clientSecret =
         value <- makeHttpRequest req
         token@(Token accessToken' tokenType') <-
             case parseEither parseJSON value of
-                Left e -> error e
+                Left e  -> error e
                 Right t -> return t
 
         unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType'
@@ -247,16 +253,18 @@ authPlugin storeToken clientID clientSecret =
         -- User's access token is saved for further access to API
         when storeToken $ setSession accessTokenKey accessToken'
 
-        personValue <- makeHttpRequest =<< personValueRequest token
+        personValReq <- personValueRequest token
+        personValue <- makeHttpRequest personValReq
+
         person <- case parseEither parseJSON personValue of
-                Left e -> error e
+                Left e  -> error e
                 Right x -> return x
 
         email <-
             case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of
                 [e] -> return e
-                [] -> error "No account email"
+                []  -> error "No account email"
-                x -> error $ "Too many account emails: " ++ show x
+                x   -> error $ "Too many account emails: " ++ show x
         setCredsRedirect $ Creds pid email $ allPersonInfo personValue
 
     dispatch _ _ = notFound
@@ -450,16 +458,16 @@ data RelationshipStatus = Single              -- ^ Person is single
 
 instance FromJSON RelationshipStatus where
     parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of
-                  "single"                    -> Single
+                  "single"                  -> Single
-                  "in_a_relationship"         -> InRelationship
+                  "in_a_relationship"       -> InRelationship
-                  "engaged"                   -> Engaged
+                  "engaged"                 -> Engaged
-                  "married"                   -> Married
+                  "married"                 -> Married
-                  "its_complicated"           -> Complicated
+                  "its_complicated"         -> Complicated
-                  "open_relationship"         -> OpenRelationship
+                  "open_relationship"       -> OpenRelationship
-                  "widowed"                   -> Widowed
+                  "widowed"                 -> Widowed
-                  "in_domestic_partnership"   -> DomesticPartnership
+                  "in_domestic_partnership" -> DomesticPartnership
-                  "in_civil_union"            -> CivilUnion
+                  "in_civil_union"          -> CivilUnion
-                  _                           -> RelationshipStatus t
+                  _                         -> RelationshipStatus t
 
 --------------------------------------------------------------------------------
 -- | The URI of the person's profile photo.
@@ -585,9 +593,19 @@ instance FromJSON EmailType where
         _         -> EmailType t
 
 allPersonInfo :: A.Value -> [(Text, Text)]
-allPersonInfo (A.Object o) = map enc $ M.toList o
+allPersonInfo (A.Object o) = map enc $ mapToList o
-    where enc (key, A.String s) = (key, s)
+  where
-          enc (key, v) = (key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
+    enc (key, A.String s) = (keyToText key, s)
+    enc (key, v) = (keyToText key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
+
+#if MIN_VERSION_aeson(2, 0, 0)
+    keyToText = Data.Aeson.Key.toText
+    mapToList = Data.Aeson.KeyMap.toList
+#else
+    keyToText = id
+    mapToList = M.toList
+#endif
+
 allPersonInfo _ = []
 
 

yesod-auth/Yesod/Auth/Hardcoded.hs

@@ -131,10 +131,9 @@ module Yesod.Auth.Hardcoded
   , loginR )
   where
 
-import           Yesod.Auth          (AuthPlugin (..), AuthRoute,
+import           Yesod.Auth          (AuthHandler, AuthPlugin (..), AuthRoute,
                                       Creds (..), Route (..), YesodAuth,
-                                      loginErrorMessageI, setCredsRedirect,
+                                      loginErrorMessageI, setCredsRedirect)
-                                      AuthHandler)
 import qualified Yesod.Auth.Message  as Msg
 import           Yesod.Core
 import           Yesod.Form          (ireq, runInputPost, textField)
@@ -159,8 +158,9 @@ authHardcoded :: YesodAuthHardcoded m => AuthPlugin m
 authHardcoded =
   AuthPlugin "hardcoded" dispatch loginWidget
   where
+    dispatch :: YesodAuthHardcoded m => Text -> [Text] -> AuthHandler m TypedContent
     dispatch "POST" ["login"] = postLoginR >>= sendResponse
-    dispatch _ _ = notFound
+    dispatch _ _              = notFound
     loginWidget toMaster = do
       request <- getRequest
       [whamlet|

yesod-auth/Yesod/Auth/Message.hs

@@ -282,13 +282,13 @@ germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"
 germanMessage LoginOpenID = "Login via OpenID"
 germanMessage LoginGoogle = "Login via Google"
 germanMessage LoginYahoo = "Login via Yahoo"
-germanMessage Email = "Email"
+germanMessage Email = "E-Mail"
-germanMessage UserName = "Benutzername" -- FIXME by Google Translate "user name"
+germanMessage UserName = "Benutzername"
 germanMessage Password = "Passwort"
 germanMessage CurrentPassword = "Aktuelles Passwort"
 germanMessage Register = "Registrieren"
 germanMessage RegisterLong = "Neuen Account registrieren"
-germanMessage EnterEmail = "Bitte die e-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."
+germanMessage EnterEmail = "Bitte die E-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."
 germanMessage ConfirmationEmailSentTitle = "Bestätigung verschickt."
 germanMessage (ConfirmationEmailSent email) =
     "Eine Bestätigung wurde an " `mappend`
@@ -308,24 +308,23 @@ germanMessage ConfirmPass = "Bestätigen"
 germanMessage PassMismatch = "Die Passwörter stimmen nicht überein"
 germanMessage PassUpdated = "Passwort überschrieben"
 germanMessage Facebook = "Login über Facebook"
-germanMessage LoginViaEmail = "Login via e-Mail"
+germanMessage LoginViaEmail = "Login via E-Mail"
 germanMessage InvalidLogin = "Ungültiger Login"
 germanMessage NowLoggedIn = "Login erfolgreich"
-germanMessage LoginTitle = "Log In"
+germanMessage LoginTitle = "Anmelden"
 germanMessage PleaseProvideUsername = "Bitte Nutzername angeben"
 germanMessage PleaseProvidePassword = "Bitte Passwort angeben"
-germanMessage NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben"
+germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben"
-germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter"
+germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter"
 germanMessage PasswordResetTitle = "Passwort zurücksetzen"
-germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"
+germanMessage ProvideIdentifier = "E-Mail-Adresse oder Nutzername"
-germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen"
+germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen"
-germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann."
+germanMessage PasswordResetPrompt = "Nach Einhabe der E-Mail-Adresse oder des Nutzernamen wird eine E-Mail zugesendet mit welcher das Passwort zurückgesetzt werden kann."
 germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"
--- TODO
+germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO
-germanMessage i@(IdentifierNotFound _) = englishMessage i
+germanMessage Logout = "Abmelden"
-germanMessage Logout = "Ausloggen" -- FIXME by Google Translate
+germanMessage LogoutTitle = "Abmelden"
-germanMessage LogoutTitle = "Ausloggen" -- FIXME by Google Translate
+germanMessage AuthError = "Fehler beim Anmelden"
-germanMessage AuthError = "Autorisierungsfehler" -- FIXME by Google Translate
 
 frenchMessage :: AuthMessage -> Text
 frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,6 @@
+cabal-version:   >=1.10
 name:            yesod-auth
-version:         1.6.10
+version:         1.6.11.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -7,7 +8,6 @@ maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        Authentication for Yesod.
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-auth>
@@ -20,8 +20,10 @@ flag network-uri
   default: True
 
 library
+    default-language: Haskell2010
     build-depends:   base                    >= 4.10      && < 5
                    , aeson                   >= 0.7
+                   , attoparsec-aeson        >= 2.1
                    , authenticate            >= 1.3.4
                    , base16-bytestring
                    , base64-bytestring
@@ -43,7 +45,7 @@ library
                    , http-types
                    , memory
                    , nonce                   >= 1.0.2     && < 1.1
-                   , persistent              >= 2.8       && < 2.11
+                   , persistent              >= 2.8
                    , random                  >= 1.0.0.2
                    , safe
                    , shakespeare
@@ -56,7 +58,7 @@ library
                    , unordered-containers
                    , wai                     >= 1.4
                    , yesod-core              >= 1.6       && < 1.7
-                   , yesod-form              >= 1.6       && < 1.7
+                   , yesod-form              >= 1.6       && < 1.8
                    , yesod-persistent        >= 1.6
 
     if flag(network-uri)

yesod-bin/AddHandler.hs

@@ -9,13 +9,18 @@ import Data.List  (isPrefixOf, isSuffixOf, stripPrefix)
 import Data.Maybe (fromMaybe, listToMaybe)
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
-#if MIN_VERSION_Cabal(2, 2, 0)
+#if MIN_VERSION_Cabal(3, 7, 0)
+import Distribution.Simple.PackageDescription (readGenericPackageDescription)
+#elif MIN_VERSION_Cabal(2, 2, 0)
 import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
 #elif MIN_VERSION_Cabal(2, 0, 0)
 import Distribution.PackageDescription.Parse (readGenericPackageDescription)
 #else
 import Distribution.PackageDescription.Parse (readPackageDescription)
 #endif
+#if MIN_VERSION_Cabal(3, 6, 0)
+import Distribution.Utils.Path
+#endif
 import Distribution.PackageDescription.Configuration (flattenPackageDescription)
 import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)
 import Distribution.Verbosity (normal)
@@ -62,18 +67,18 @@ addHandlerInteractive :: IO ()
 addHandlerInteractive = do
     cabal <- getCabal
     let routeInput = do
-        putStr "Name of route (without trailing R): "
+          putStr "Name of route (without trailing R): "
-        hFlush stdout
+          hFlush stdout
-        name <- getLine
+          name <- getLine
-        checked <- checkRoute name cabal
+          checked <- checkRoute name cabal
-        case checked of
+          case checked of
-            Left err@EmptyRoute -> (error . show) err
+              Left err@EmptyRoute -> (error . show) err
-            Left err@RouteCaseError -> print err >> routeInput
+              Left err@RouteCaseError -> print err >> routeInput
-            Left err@(RouteExists _) -> do
+              Left err@(RouteExists _) -> do
-              print err
+                print err
-              putStrLn "Try another name or leave blank to exit"
+                putStrLn "Try another name or leave blank to exit"
-              routeInput
+                routeInput
-            Right p -> return p
+              Right p -> return p
 
     routePair <- routeInput
     putStr "Enter route pattern (ex: /entry/#EntryId): "
@@ -84,13 +89,22 @@ addHandlerInteractive = do
     methods <- getLine
     addHandlerFiles cabal routePair pattern methods
 
+getRoutesFilePath :: IO FilePath
+getRoutesFilePath = do
+    let oldPath = "config/routes"
+    oldExists <- doesFileExist oldPath
+    pure $ if oldExists
+        then oldPath
+        else "config/routes.yesodroutes"
+
 addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO ()
 addHandlerFiles cabal (name, handlerFile) pattern methods = do
     src <- getSrcDir cabal
     let applicationFile = concat [src, "/Application.hs"]
     modify applicationFile $ fixApp name
     modify cabal $ fixCabal name
-    modify "config/routes" $ fixRoutes name pattern methods
+    routesPath <- getRoutesFilePath
+    modify routesPath $ fixRoutes name pattern methods
     writeFile handlerFile $ mkHandler name pattern methods
     specExists <- doesFileExist specFile
     unless specExists $
@@ -238,4 +252,8 @@ getSrcDir cabal = do
 #endif
     let buildInfo = allBuildInfo pd
         srcDirs = concatMap hsSourceDirs buildInfo
+#if MIN_VERSION_Cabal(3, 6, 0)
+    return $ maybe "." getSymbolicPath $ listToMaybe srcDirs
+#else
     return $ fromMaybe "." $ listToMaybe srcDirs
+#endif

yesod-bin/ChangeLog.md

@@ -1,3 +1,29 @@
+# ChangeLog for yesod-bin
+
+## 1.6.2.2
+
+* Support Cabal 3.8 [#1769](https://github.com/yesodweb/yesod/pull/1769)
+
+## 1.6.2.1
+
+* Support Cabal 3.6 [#1754](https://github.com/yesodweb/yesod/pull/1754)
+
+## 1.6.2
+
+* aeson 2.0
+
+## 1.6.1
+
+Added command line options `cert` and `key` to allow TLS certificate and key files to be passed to `yesod devel` [#1717](https://github.com/yesodweb/yesod/pull/1717)
+
+## 1.6.0.6
+
+Fix the `add-handler` subcommand to support both the old default routes filename (`routes`) and the new one (`routes.yesodroutes`) [#1688](https://github.com/yesodweb/yesod/pull/1688)
+
+## 1.6.0.5
+
+* Use process groups to ensure GHC is killed on Ctrl-C [#1683](https://github.com/yesodweb/yesod/pull/1683)
+
 ## 1.6.0.4
 
 * Support Cabal 3.0

yesod-bin/Devel.hs

@@ -28,6 +28,9 @@ import           Data.String                           (fromString)
 import           Data.Time                             (getCurrentTime)
 import qualified Distribution.Package                  as D
 import qualified Distribution.PackageDescription       as D
+#if MIN_VERSION_Cabal(3,8,0)
+import qualified Distribution.Simple.PackageDescription as D
+#endif
 #if MIN_VERSION_Cabal(2, 2, 0)
 import qualified Distribution.PackageDescription.Parsec as D
 #else
@@ -56,7 +59,7 @@ import           Network.Wai                           (requestHeaderHost,
                                                         responseLBS)
 import           Network.Wai.Handler.Warp              (defaultSettings, runSettings,
                                                         setPort, setHost)
-import           Network.Wai.Handler.WarpTLS           (runTLS,
+import           Network.Wai.Handler.WarpTLS           (runTLS, tlsSettings,
                                                         tlsSettingsMemory)
 import           Network.Wai.Parse                     (parseHttpAccept)
 import           Say
@@ -126,6 +129,7 @@ data DevelOpts = DevelOpts
       , proxyTimeout    :: Int
       , useReverseProxy :: Bool
       , develHost       :: Maybe String
+      , cert            :: Maybe (FilePath, FilePath)
       } deriving (Show, Eq)
 
 -- | Run a reverse proxy from the develPort and develTlsPort ports to
@@ -170,10 +174,12 @@ reverseProxy opts appPortVar = do
                 manager
         defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings
         runProxyTls port app = do
-          let cert = $(embedFile "certificate.pem")
+          let certDef = $(embedFile "certificate.pem")
-              key = $(embedFile "key.pem")
+              keyDef = $(embedFile "key.pem")
-              tlsSettings = tlsSettingsMemory cert key
+              theSettings = case cert opts of
-          runTLS tlsSettings (setPort port defaultSettings') $ \req send -> do
+                Nothing -> tlsSettingsMemory certDef keyDef
+                Just (c,k) -> tlsSettings c k
+          runTLS theSettings (setPort port defaultSettings') $ \req send -> do
             let req' = req
                     { requestHeaders
                         = ("X-Forwarded-Proto", "https")
@@ -345,7 +351,8 @@ devel opts passThroughArgs = do
         myPath <- getExecutablePath
         let procConfig = setStdout createSource
                        $ setStderr createSource
-                       $ setDelegateCtlc True $ proc "stack" $
+                       $ setCreateGroup True -- because need when yesod-bin killed and kill child ghc
+                       $ proc "stack" $
                 [ "build"
                 , "--fast"
                 , "--file-watch"

yesod-bin/Keter.hs

@@ -1,10 +1,16 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 module Keter
     ( keter
     ) where
 
 import Data.Yaml
+
+#if MIN_VERSION_aeson(2, 0, 0)
+import qualified Data.Aeson.KeyMap as Map
+#else
 import qualified Data.HashMap.Strict as Map
+#endif
 import qualified Data.Text as T
 import System.Environment (getEnvironment)
 import System.Exit

yesod-bin/README.md

@@ -83,6 +83,7 @@ Now some weird notes:
   `yesod devel` also writes to a file
   `yesod-devel/devel-terminate`. Your devel script should respect this
   file and shutdown whenever it exists.
+  (It may be fixed in 1.6.0.5.)
 * If your .cabal file defines them, `yesod devel` will tell Stack to
   build with the flags `dev` and `library-only`. You can use this to
   speed up compile times (biggest win: skip building executables, thus

yesod-bin/main.hs

@@ -30,12 +30,13 @@ data Command = Init [String]
              | Build { buildExtraArgs   :: [String] }
              | Touch
              | Devel { develSuccessHook :: Maybe String
-                     , develExtraArgs    :: [String]
+                     , develExtraArgs   :: [String]
                      , develPort        :: Int
                      , develTlsPort     :: Int
                      , proxyTimeout     :: Int
                      , noReverseProxy   :: Bool
                      , develHost        :: Maybe String
+                     , cert             :: Maybe (FilePath, FilePath)
                      }
              | DevelSignal
              | Test
@@ -90,6 +91,7 @@ main = do
                              , proxyTimeout = proxyTimeout
                              , useReverseProxy = not noReverseProxy
                              , develHost    = develHost
+                             , cert         = cert
                              } develExtraArgs
     DevelSignal     -> develSignal
   where
@@ -167,6 +169,11 @@ develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "C
                             <> help "Disable reverse proxy" )
                      <*> optStr (long "host" <> metavar "HOST"
                             <> help "Host interface to bind to; IP address, '*' for all interfaces, '*4' for IP4, '*6' for IP6")
+                     <*> optional ( (,)
+                            <$> strOption (long "cert" <> metavar "CERT"
+                                   <> help "Path to TLS certificate file, requires that --key is also defined")
+                            <*> strOption (long "key" <> metavar "KEY"
+                                   <> help "Path to TLS key file, requires that --cert is also defined") )
 
 extraStackArgs :: Parser [String]
 extraStackArgs = many (strOption ( long "extra-stack-arg" <> short 'e' <> metavar "ARG"

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.6.0.4
+version:         1.6.2.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -8,7 +8,7 @@ synopsis:        The yesod helper executable.
 description:     See README.md for more information
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.6
+cabal-version:   >= 1.10
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 
@@ -19,6 +19,7 @@ extra-source-files:
   *.pem
 
 executable             yesod
+    default-language: Haskell2010
     if os(windows)
         cpp-options:     -DWINDOWS
     if os(openbsd)
@@ -34,7 +35,7 @@ executable             yesod
                      , directory          >= 1.2.1
                      , file-embed
                      , filepath           >= 1.1
-                     , fsnotify           >= 0.0          && < 0.4
+                     , fsnotify
                      , http-client        >= 0.4.7
                      , http-client-tls
                      , http-reverse-proxy >= 0.4
@@ -60,6 +61,7 @@ executable             yesod
                      , warp-tls           >= 3.0.1
                      , yaml               >= 0.8          && < 0.12
                      , zlib               >= 0.5
+                     , aeson
 
     ghc-options:       -Wall -threaded -rtsopts
     main-is:           main.hs

yesod-core/ChangeLog.md

@@ -1,5 +1,109 @@
 # ChangeLog for yesod-core
 
+## 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

yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Yesod.Core.Class.Breadcrumbs where
 
 import Yesod.Core.Handler
@@ -15,7 +16,7 @@ class YesodBreadcrumbs site where
 
 -- | Gets the title of the current page and the hierarchy of parent pages,
 -- along with their respective titles.
-breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)])
+breadcrumbs :: (YesodBreadcrumbs site, Show (Route site), Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)])
 breadcrumbs = do
     x <- getCurrentRoute
     case x of
@@ -26,6 +27,8 @@ breadcrumbs = do
             return (title, z)
   where
     go back Nothing = return back
-    go back (Just this) = do
+    go back (Just this)
-        (title, next) <- breadcrumb this
+      | this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this
-        go ((this, title) : back) next
+      | otherwise = do
+          (title, next) <- breadcrumb this
+          go ((this, title) : back) next

yesod-core/src/Yesod/Core/Class/Handler.hs

@@ -19,7 +19,9 @@ 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  )
@@ -76,7 +78,9 @@ instance MonadHandler (WidgetFor site) where
 #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)
@@ -104,7 +108,9 @@ liftWidgetT = liftWidget
 #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)

yesod-core/src/Yesod/Core/Class/Yesod.hs

@@ -1,7 +1,9 @@
-{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Yesod.Core.Class.Yesod where
 
 import           Yesod.Core.Content
@@ -52,8 +54,10 @@ import           Yesod.Core.Types
 import           Yesod.Core.Internal.Session
 import           Yesod.Core.Widget
 import Data.CaseInsensitive (CI)
+import qualified Network.Wai.Handler.Warp as Warp
 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.
@@ -70,6 +74,16 @@ class RenderRoute site => Yesod site where
     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'.
@@ -87,6 +101,8 @@ class RenderRoute site => Yesod site where
             <html>
                 <head>
                     <title>#{pageTitle p}
+                    $maybe description <- pageDescription p
+                      <meta name="description" content="#{description}">
                     ^{pageHead p}
                 <body>
                     $forall (status, msg) <- msgs
@@ -531,16 +547,17 @@ widgetToPageContent :: Yesod site
                     => WidgetFor site ()
                     -> HandlerFor site (PageContent (Route site))
 widgetToPageContent w = do
-  jsAttrs <- jsAttributesHandler
+ jsAttrs <- jsAttributesHandler
-  HandlerFor $ \hd -> do
+ HandlerFor $ \hd -> do
   master <- unHandlerFor getYesod hd
   ref <- newIORef mempty
   unWidgetFor w WidgetData
     { wdRef = ref
     , wdHandler = hd
     }
-  GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref
+  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'
 
@@ -610,7 +627,7 @@ widgetToPageContent w = do
             ^{regularScriptLoad}
         |]
 
-    return $ PageContent title headAll $
+    return $ PageContent title description headAll $
         case jsLoader master of
             BottomOfBody -> bodyScript
             _ -> body

yesod-core/src/Yesod/Core/Content.hs

@@ -64,6 +64,7 @@ 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)
@@ -103,6 +104,8 @@ 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
@@ -276,6 +279,8 @@ 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

yesod-core/src/Yesod/Core/Dispatch.hs

@@ -10,13 +10,24 @@ module Yesod.Core.Dispatch
     , parseRoutesFile
     , parseRoutesFileNoCheck
     , mkYesod
+    , mkYesodOpts
     , mkYesodWith
       -- ** More fine-grained
     , mkYesodData
+    , mkYesodDataOpts
     , mkYesodSubData
+    , mkYesodSubDataOpts
     , mkYesodDispatch
+    , mkYesodDispatchOpts
     , mkYesodSubDispatch
+      -- *** Route generation options
+    , RouteOpts
+    , defaultOpts
+    , setEqDerived
+    , setShowDerived
+    , setReadDerived
       -- *** Helpers
+    , defaultGen
     , getGetMaxExpires
       -- ** Path pieces
     , PathPiece (..)
@@ -46,6 +57,7 @@ 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.Lazy as BL
@@ -59,7 +71,7 @@ import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
 import Text.Read (readMaybe)
 import System.Environment (getEnvironment)
-import qualified System.Random as Random
+import System.Entropy (getEntropy)
 import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
 import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
 
@@ -92,8 +104,21 @@ toWaiAppPlain site = do
             , yreGetMaxExpires = getMaxExpires
             }
 
+-- | 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 = Random.getStdRandom Random.next
+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
@@ -172,6 +197,16 @@ toWaiAppLogger logger site = do
 -- 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.
 --

yesod-core/src/Yesod/Core/Handler.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TemplateHaskell            #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -244,6 +245,7 @@ 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
@@ -260,7 +262,7 @@ import qualified Data.Word8 as W8
 import qualified Data.Foldable as Fold
 import           Control.Monad.Logger (MonadLogger, logWarnS)
 
-type HandlerT site (m :: * -> *) = HandlerFor site
+type HandlerT site (m :: Type -> Type) = HandlerFor site
 {-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
 
 get :: MonadHandler m => m GHState
@@ -369,10 +371,10 @@ getPostParams = do
 getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
 getCurrentRoute = rheRoute <$> askHandlerEnv
 
--- | Returns a function that runs 'HandlerT' actions inside @IO@.
+-- | Returns a function that runs 'HandlerFor' actions inside @IO@.
 --
--- Sometimes you want to run an inner 'HandlerT' action outside
+-- Sometimes you want to run an inner 'HandlerFor' action outside
--- the control flow of an HTTP request (on the outer 'HandlerT'
+-- the control flow of an HTTP request (on the outer 'HandlerFor'
 -- action).  For example, you may want to spawn a new thread:
 --
 -- @
@@ -380,30 +382,30 @@ getCurrentRoute = rheRoute <$> askHandlerEnv
 -- getFooR = do
 --   runInnerHandler <- handlerToIO
 --   liftIO $ forkIO $ runInnerHandler $ do
---     /Code here runs inside GHandler but on a new thread./
+--     /Code here runs inside HandlerFor but on a new thread./
---     /This is the inner GHandler./
+--     /This is the inner HandlerFor./
 --     ...
 --   /Code here runs inside the request's control flow./
---   /This is the outer GHandler./
+--   /This is the outer HandlerFor./
 --   ...
 -- @
 --
 -- Another use case for this function is creating a stream of
--- server-sent events using 'GHandler' actions (see
+-- server-sent events using 'HandlerFor' actions (see
 -- @yesod-eventsource@).
 --
--- Most of the environment from the outer 'GHandler' is preserved
+-- Most of the environment from the outer 'HandlerFor' is preserved
--- on the inner 'GHandler', however:
+-- 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 'CacheKey').
+--  * The cache is cleared (see 'cached').
 --
--- Changes to the response made inside the inner 'GHandler' are
+-- Changes to the response made inside the inner 'HandlerFor' are
 -- ignored (e.g., session variables, cookies, response headers).
--- This allows the inner 'GHandler' to outlive the outer
+-- This allows the inner 'HandlerFor' to outlive the outer
--- 'GHandler' (e.g., on the @forkIO@ example above, a response
+-- '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 =
@@ -428,7 +430,7 @@ handlerToIO =
     -- xx From this point onwards, no references to oldHandlerData xx
     liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())
 
-    -- Return GHandler running function.
+    -- Return HandlerFor running function.
     return $ \(HandlerFor f) ->
       liftIO $
       runResourceT $ withInternalState $ \resState -> do
@@ -1225,10 +1227,10 @@ cacheBySet key value = do
 -- Languages are determined based on the following (in descending order
 -- of preference):
 --
--- * The _LANG user session variable.
---
 -- * The _LANG get parameter.
 --
+-- * The _LANG user session variable.
+--
 -- * The _LANG cookie.
 --
 -- * Accept-Language HTTP header.
@@ -1237,11 +1239,12 @@ cacheBySet key value = do
 -- 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 = do
+languages = reqLangs <$> getRequest
-    mlang <- lookupSession langKey
-    langs <- reqLangs <$> getRequest
-    return $ maybe id (:) mlang langs
 
 lookup' :: Eq a => a -> [(a, b)] -> [b]
 lookup' a = map snd . filter (\x -> a == fst x)
@@ -1463,8 +1466,8 @@ respond ct = return . TypedContent ct . toContent
 
 -- | Use a @Source@ for the response body.
 --
--- Note that, for ease of use, the underlying monad is a @HandlerT@. This
+-- Note that, for ease of use, the underlying monad is a @HandlerFor@. This
--- implies that you can run any @HandlerT@ action. However, since a streaming
+-- 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.
@@ -1475,8 +1478,8 @@ respondSource :: ContentType
               -> 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 HandlerT.
+    -- environment provided by the server is the same one used in HandlerFor.
-    -- This is a safe assumption assuming the HandlerT is run correctly.
+    -- This is a safe assumption assuming the HandlerFor is run correctly.
     return $ TypedContent ctype $ ContentSource
            $ transPipe (lift . flip unHandlerFor hd) src
 

yesod-core/src/Yesod/Core/Internal/Run.hs

@@ -1,13 +1,28 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE PatternGuards     #-}
+{-# LANGUAGE PatternGuards       #-}
-{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TemplateHaskell     #-}
-{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE TupleSections       #-}
-{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleContexts    #-}
-module Yesod.Core.Internal.Run where
+{-# LANGUAGE ScopedTypeVariables #-}
-
+module Yesod.Core.Internal.Run
+  ( toErrorHandler
+  , errFromShow
+  , basicRunHandler
+  , handleError
+  , handleContents
+  , evalFallback
+  , runHandler
+  , safeEh
+  , runFakeHandler
+  , yesodRunner
+  , yesodRender
+  , resolveApproot
+  )
+  where
 
+import qualified Control.Exception as EUnsafe
 import Yesod.Core.Internal.Response
 import           Data.ByteString.Builder      (toLazyByteString)
 import qualified Data.ByteString.Lazy         as BL
@@ -39,6 +54,8 @@ import           Yesod.Core.Internal.Util     (getCurrentMaxExpiresRFC1123)
 import           Yesod.Routes.Class           (Route, renderRoute)
 import           Control.DeepSeq              (($!!), NFData)
 import           UnliftIO.Exception
+import           UnliftIO(MonadUnliftIO, withRunInIO)
+import           Data.Proxy(Proxy(..))
 
 -- | Convert a synchronous exception into an ErrorResponse
 toErrorHandler :: SomeException -> IO ErrorResponse
@@ -71,7 +88,7 @@ basicRunHandler rhe handler yreq resState = do
 
     -- Run the handler itself, capturing any runtime exceptions and
     -- converting them into a @HandlerContents@
-    contents' <- catchAny
+    contents' <- rheCatchHandlerExceptions rhe
         (do
             res <- unHandlerFor handler (hd istate)
             tc <- evaluate (toTypedContent res)
@@ -172,16 +189,19 @@ handleContents handleError' finalSession headers contents =
 -- | 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)
-             => HandlerContents
+             => (forall a. IO a -> (SomeException -> IO a) -> IO a)
+             -> HandlerContents
              -> w
              -> IO (w, HandlerContents)
-evalFallback contents val = catchAny
+evalFallback catcher contents val = catcher
     (fmap (, contents) (evaluate $!! val))
     (fmap ((mempty, ) . HCError) . toErrorHandler)
 
 -- | Function used internally by Yesod in the process of converting a
--- 'HandlerT' into an 'Application'. Should not be needed by users.
+-- 'HandlerFor' into an 'Application'. Should not be needed by users.
 runHandler :: ToTypedContent c
            => RunHandlerEnv site site
            -> HandlerFor site c
@@ -192,8 +212,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
 
     -- Evaluate the unfortunately-lazy session and headers,
     -- propagating exceptions into the contents
-    (finalSession, contents1) <- evalFallback contents0 (ghsSession state)
+    (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)
-    (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
+    (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
     contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
 
     -- Convert the HandlerContents into the final YesodResponse
@@ -216,27 +236,27 @@ safeEh log' er req = do
         (toContent ("Internal Server Error" :: S.ByteString))
         (reqSession req)
 
--- | Run a 'HandlerT' completely outside of Yesod.  This
+-- | 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 'HandlerT'
+-- 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
--- @HandlerT@.  The only useful information the @HandlerT@ may
+-- @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
--- @HandlerT@ is completely ignored, including changes to the
+-- @HandlerFor@ is completely ignored, including changes to the
 -- session, cookies or headers.  We only return you the
--- @HandlerT@'s return value.
+-- @HandlerFor@'s return value.
-runFakeHandler :: (Yesod site, MonadIO m) =>
+runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
                   SessionMap
                -> (site -> Logger)
                -> site
@@ -257,6 +277,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
             , rheLog = messageLoggerSource site $ logger site
             , rheOnError = errHandler
             , rheMaxExpires = maxExpires
+            , rheCatchHandlerExceptions = catchHandlerExceptions site
             }
         handler'
       errHandler err req = do
@@ -298,7 +319,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
   _ <- runResourceT $ yapp fakeRequest
   I.readIORef ret
 
-yesodRunner :: (ToTypedContent res, Yesod site)
+yesodRunner :: forall res site . (ToTypedContent res, Yesod site)
             => HandlerFor site res
             -> YesodRunnerEnv site
             -> Maybe (Route site)
@@ -333,6 +354,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
               , rheLog = log'
               , rheOnError = safeEh log'
               , rheMaxExpires = maxExpires
+              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite
               }
           rhe = rheSafe
               { rheOnError = runHandler rheSafe . errorHandler

yesod-core/src/Yesod/Core/Internal/TH.hs

@@ -1,10 +1,48 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
-module Yesod.Core.Internal.TH where
+{-# LANGUAGE RankNTypes #-}
+module Yesod.Core.Internal.TH
+    ( mkYesod
+    , mkYesodOpts
+
+    , mkYesodWith
+
+    , mkYesodData
+    , mkYesodDataOpts
+
+    , mkYesodSubData
+    , mkYesodSubDataOpts
+
+    , mkYesodWithParser
+    , mkYesodWithParserOpts
+
+    , mkYesodDispatch
+    , mkYesodDispatchOpts
+
+    , masterTypeSyns
+
+    , mkYesodGeneral
+    , mkYesodGeneralOpts
+
+    , mkMDS
+    , mkDispatchInstance
+
+    , mkYesodSubDispatch
+    
+    , subTopDispatch
+    , instanceD
+
+    , RouteOpts
+    , defaultOpts
+    , setEqDerived
+    , setShowDerived
+    , setReadDerived
+    )
+ where
 
 import Prelude hiding (exp)
 import Yesod.Core.Handler
@@ -22,6 +60,7 @@ import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
 
 import Yesod.Routes.TH
 import Yesod.Routes.Parse
+import Yesod.Core.Content (ToTypedContent (..))
 import Yesod.Core.Types
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
@@ -35,7 +74,17 @@ import Yesod.Core.Internal.Run
 mkYesod :: String -- ^ name of the argument datatype
         -> [ResourceTree String]
         -> Q [Dec]
-mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return
+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. 
@@ -48,15 +97,30 @@ mkYesodWith :: [[String]] -- ^ list of contexts
             -> 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 name resS = fst <$> mkYesodWithParser name False return resS
+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 name resS = fst <$> mkYesodWithParser name True return resS
+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
+
 
 -- | Parses contexts and type arguments out of name before generating TH.
 mkYesodWithParser :: String                    -- ^ foundation type
@@ -64,11 +128,22 @@ mkYesodWithParser :: String                    -- ^ foundation type
                   -> (Exp -> Q Exp)            -- ^ unwrap handler
                   -> [ResourceTree String]
                   -> Q([Dec],[Dec])
-mkYesodWithParser name isSub f resS = do
+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
     let (name', rest, cxt) = case parse parseName "" name of
             Left err -> error $ show err
             Right a -> a
-    mkYesodGeneral cxt name' rest isSub f resS
+    mkYesodGeneralOpts opts cxt name' rest isSub f resS
 
     where
         parseName = do
@@ -100,19 +175,28 @@ mkYesodWithParser name isSub f resS = do
         parseContexts = 
             sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
 
+
 -- | See 'mkYesodData'.
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodDispatch name = fmap snd . mkYesodWithParser name False return
+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
+
 
 -- | 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)
+    [ TySynD (mkName "Handler") (fmap plainTV vs)
       $ ConT ''HandlerFor `AppT` site
-    , TySynD (mkName "Widget")  (fmap PlainTV vs)
+    , 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
@@ -120,7 +204,20 @@ mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in Ren
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral appCxt' namestr mtys isSub f resS = do
+mkYesodGeneral = mkYesodGeneralOpts defaultOpts
+
+-- |
+--
+-- @since 1.6.25.0
+mkYesodGeneralOpts :: RouteOpts                 -- ^ Options to adjust route creation
+                   -> [[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])
+mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
     let appCxt = fmap (\(c:rest) -> 
             foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
           ) appCxt'
@@ -141,11 +238,14 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
     let name = mkName namestr
     -- Generate as many variable names as the arity indicates
     vns <- replicateM (arity - length mtys) $ newName "t"
-        -- Base type (site type with variables)
+    -- types that you apply to get a concrete site name
     let argtypes = fmap nameToType mtys ++ fmap VarT vns
-        site = foldl' AppT (ConT name) argtypes
+    -- typevars that should appear in synonym head
+    let argvars = (fmap mkName . filter isTvar) mtys ++ vns
+        -- Base type (site type with variables)
+    let site = foldl' AppT (ConT name) argtypes
         res = map (fmap (parseType . dropBracket)) resS
-    renderRouteDec <- mkRenderRouteInstance appCxt site res
+    renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res
     routeAttrsDec  <- mkRouteAttrsInstance appCxt site res
     dispatchDec    <- mkDispatchInstance site appCxt f res
     parseRoute <- mkParseRouteInstance appCxt site res
@@ -160,22 +260,15 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
             , renderRouteDec
             , [routeAttrsDec]
             , resourcesDec
-            , if isSub then [] else masterTypeSyns vns site
+            , if isSub then [] else masterTypeSyns argvars site
             ]
     return (dataDec, dispatchDec)
 
-mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
+
-mkMDS f rh = MkDispatchSettings
+mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
+mkMDS f rh sd = MkDispatchSettings
     { mdsRunHandler = rh
-    , mdsSubDispatcher =
+    , mdsSubDispatcher = sd
-        [|\parentRunner getSub toParent env -> yesodSubDispatch
-                                 YesodSubRunnerEnv
-                                    { ysreParentRunner = parentRunner
-                                    , ysreGetSub = getSub
-                                    , ysreToParentRoute = toParent
-                                    , ysreParentEnv = env
-                                    }
-                              |]
     , mdsGetPathInfo = [|W.pathInfo|]
     , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
     , mdsMethod = [|W.requestMethod|]
@@ -196,15 +289,35 @@ mkDispatchInstance :: Type                      -- ^ The master site type
                    -> [ResourceTree c]          -- ^ The resource
                    -> DecsQ
 mkDispatchInstance master cxt f res = do
-    clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res
+    clause' <- 
+        mkDispatchClause 
+            (mkMDS 
+                f 
+                [|yesodRunner|] 
+                [|\parentRunner getSub toParent env -> yesodSubDispatch
+                    YesodSubRunnerEnv
+                    { ysreParentRunner = parentRunner
+                    , ysreGetSub = getSub
+                    , ysreToParentRoute = toParent
+                    , ysreParentEnv = env
+                    }
+                |])
+            res
     let thisDispatch = FunD 'yesodDispatch [clause']
     return [instanceD cxt yDispatch [thisDispatch]]
   where
     yDispatch = ConT ''YesodDispatch `AppT` master
 
+
 mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
 mkYesodSubDispatch res = do
-    clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
+    clause' <- 
+        mkDispatchClause
+            (mkMDS 
+                return 
+                [|subHelper|] 
+                [|subTopDispatch|]) 
+        res
     inner <- newName "inner"
     let innerFun = FunD inner [clause']
     helper <- newName "helper"
@@ -216,5 +329,26 @@ mkYesodSubDispatch res = do
                 ]
     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
+            })
+
 instanceD :: Cxt -> Type -> [Dec] -> Dec
 instanceD = InstanceD Nothing

yesod-core/src/Yesod/Core/Types.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
 module Yesod.Core.Types where
 
 import Data.Aeson (ToJSON)
@@ -55,7 +56,7 @@ import           Control.Monad.Reader               (MonadReader (..))
 import Control.DeepSeq (NFData (rnf))
 import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
 import Control.Monad.Logger (MonadLoggerIO (..))
-import UnliftIO (MonadUnliftIO (..))
+import UnliftIO (MonadUnliftIO (..), SomeException)
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -182,6 +183,11 @@ data RunHandlerEnv child site = RunHandlerEnv
       --
       -- 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
@@ -196,7 +202,13 @@ data YesodRunnerEnv site = YesodRunnerEnv
     , yreSite           :: !site
     , yreSessionBackend :: !(Maybe SessionBackend)
     , yreGen            :: !(IO Int)
-    -- ^ Generate a random number
+    -- ^ 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)
     }
 
@@ -231,7 +243,7 @@ data GHState = GHState
 
 -- | 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 'HandlerT' monad and template haskell code should hide it away.
+-- 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
@@ -283,9 +295,10 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
 --
 -- > PageContent url -> HtmlUrl url
 data PageContent url = PageContent
-    { pageTitle :: !Html
+    { pageTitle       :: !Html
-    , pageHead  :: !(HtmlUrl url)
+    , pageDescription :: !(Maybe Text)
-    , pageBody  :: !(HtmlUrl url)
+    , pageHead        :: !(HtmlUrl url)
+    , pageBody        :: !(HtmlUrl url)
     }
 
 data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
@@ -326,11 +339,28 @@ newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
 -- | 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
 
@@ -364,6 +394,7 @@ data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :
 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 Monoid
@@ -379,6 +410,7 @@ 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
@@ -386,20 +418,21 @@ data GWData a = GWData
     , gwdHead        :: !(Head a)
     }
 instance Monoid (GWData a) where
-    mempty = GWData mempty mempty mempty mempty mempty mempty mempty
+    mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty
 #if !(MIN_VERSION_base(4,11,0))
     mappend = (<>)
 #endif
 instance Semigroup (GWData a) where
-    GWData a1 a2 a3 a4 a5 a6 a7 <>
+    GWData a1 a2 a3 a4 a5 a6 a7 a8 <>
-      GWData b1 b2 b3 b4 b5 b6 b7 = GWData
+      GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData
         (mappend a1 b1)
         (mappend a2 b2)
         (mappend a3 b3)
         (mappend a4 b4)
-        (unionWith mappend a5 b5)
+        (mappend a5 b5)
-        (mappend a6 b6)
+        (unionWith mappend a6 b6)
         (mappend a7 b7)
+        (mappend a8 b8)
 
 data HandlerContents =
       HCContent !H.Status !TypedContent
@@ -456,7 +489,7 @@ instance MonadLogger (WidgetFor site) where
 instance MonadLoggerIO (WidgetFor site) where
     askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
 
--- Instances for HandlerT
+-- Instances for HandlerFor
 instance Applicative (HandlerFor site) where
     pure = HandlerFor . const . return
     (<*>) = ap

yesod-core/src/Yesod/Core/Widget.hs

@@ -33,6 +33,8 @@ module Yesod.Core.Widget
     , setTitleI
     , setDescription
     , setDescriptionI
+    , setDescriptionIdemp
+    , setDescriptionIdempI
     , setOGType
     , setOGImage
       -- ** CSS
@@ -64,6 +66,7 @@ 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)
@@ -77,7 +80,7 @@ import qualified Data.Text.Lazy.Builder as TB
 import Yesod.Core.Types
 import Yesod.Core.Class.Handler
 
-type WidgetT site (m :: * -> *) = WidgetFor site
+type WidgetT site (m :: Type -> Type) = WidgetFor site
 {-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
 
 preEscapedLazyText :: TL.Text -> Html
@@ -87,19 +90,19 @@ 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
+    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 (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
+    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 (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
+    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 (Just x) mempty
+    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 (Just $ const x) mempty
+    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
@@ -130,9 +133,9 @@ instance render ~ RY site => ToWidgetMedia site (render -> Css) where
 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 (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
+    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 (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
+    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 ()
@@ -150,7 +153,7 @@ 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 . Head
+    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
@@ -181,7 +184,7 @@ instance ToWidgetHead site Html where
 --    * 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
+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty
 
 -- | Set the localised page title.
 --
@@ -208,6 +211,14 @@ 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@.
@@ -220,13 +231,55 @@ 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 name="og:type" content=#{a}>|]
+setOGType a = toWidgetHead $ [hamlet|<meta property="og:type" content=#{a}>|]
 
 -- | Add OpenGraph image meta tag to the head of the page
 --
@@ -241,7 +294,7 @@ setOGType a = toWidgetHead $ [hamlet|<meta name="og:type" content=#{a}>|]
 --
 -- @since 1.6.18
 setOGImage :: MonadWidget m => Text -> m ()
-setOGImage a = toWidgetHead $ [hamlet|<meta name="og:image" content=#{a}>|]
+setOGImage a = toWidgetHead $ [hamlet|<meta property="og:image" content=#{a}>|]
 
 -- | Link to the specified local stylesheet.
 addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
@@ -252,7 +305,7 @@ addStylesheetAttrs :: MonadWidget m
                    => Route (HandlerSite m)
                    -> [(Text, Text)]
                    -> m ()
-addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
+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 ()
@@ -260,7 +313,7 @@ addStylesheetRemote = flip addStylesheetRemoteAttrs []
 
 -- | Link to the specified remote stylesheet.
 addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
-addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
+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
@@ -278,7 +331,7 @@ 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 (toUnique $ Script (Local x) y) mempty mempty mempty mempty
+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 ()
@@ -286,7 +339,7 @@ addScriptRemote = flip addScriptRemoteAttrs []
 
 -- | Link to the specified remote script.
 addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
-addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
+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

yesod-core/src/Yesod/Routes/Parse.hs

@@ -11,6 +11,7 @@ module Yesod.Routes.Parse
     , TypeTree (..)
     , dropBracket
     , nameToType
+    , isTvar
     ) where
 
 import Language.Haskell.TH.Syntax
@@ -35,9 +36,15 @@ parseRoutes = QuasiQuoter { quoteExp = x }
             [] -> lift res
             z -> error $ 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
 
@@ -258,8 +265,13 @@ ttToType (TTApp x y) = ttToType x `AppT` ttToType y
 ttToType (TTList t) = ListT `AppT` ttToType t
 
 nameToType :: String -> Type
-nameToType t@(h:_) | isLower h = VarT $ mkName t
+nameToType t = if isTvar t
-nameToType t = ConT $ mkName t
+               then VarT $ mkName t
+               else ConT $ mkName t
+
+isTvar :: String -> Bool
+isTvar (h:_) = isLower h
+isTvar _     = False
 
 pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
 pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)

yesod-core/src/Yesod/Routes/TH/Dispatch.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}
 module Yesod.Routes.TH.Dispatch
     ( MkDispatchSettings (..)
@@ -73,7 +74,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
     handlePiece (Static str) = return (LitP $ StringL str, Nothing)
     handlePiece (Dynamic _) = do
         x <- newName "dyn"
-        let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])
+        let pat = ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x])
         return (pat, Just $ VarE x)
 
     handlePieces :: [Piece a] -> Q ([Pat], [Exp])
@@ -86,7 +87,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
     mkPathPat final =
         foldr addPat final
       where
-        addPat x y = ConP '(:) [x, y]
+        addPat x y = conPCompat '(:) [x, y]
 
     go :: SDC -> ResourceTree a -> Q Clause
     go sdc (ResourceParent name _check pieces children) = do
@@ -124,11 +125,11 @@ mkDispatchClause MkDispatchSettings {..} resources = do
                 Methods multi methods -> do
                     (finalPat, mfinalE) <-
                         case multi of
-                            Nothing -> return (ConP '[] [], Nothing)
+                            Nothing -> return (conPCompat '[] [], Nothing)
                             Just _ -> do
                                 multiName <- newName "multi"
                                 let pat = ViewP (VarE 'fromPathMultiPiece)
-                                                (ConP 'Just [VarP multiName])
+                                                (conPCompat 'Just [VarP multiName])
                                 return (pat, Just $ VarE multiName)
 
                     let dynsMulti =
@@ -200,3 +201,10 @@ mkDispatchClause MkDispatchSettings {..} resources = do
 defaultGetHandler :: Maybe String -> String -> Q Exp
 defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s
 defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s
+
+conPCompat :: Name -> [Pat] -> Pat
+conPCompat n pats = ConP n
+#if MIN_VERSION_template_haskell(2,18,0)
+                         []
+#endif
+                         pats

yesod-core/src/Yesod/Routes/TH/RenderRoute.hs

@@ -1,9 +1,20 @@
-{-# LANGUAGE TemplateHaskell, CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
 module Yesod.Routes.TH.RenderRoute
     ( -- ** RenderRoute
       mkRenderRouteInstance
+    , mkRenderRouteInstanceOpts
     , mkRouteCons
+    , mkRouteConsOpts
     , mkRenderRouteClauses
+
+    , RouteOpts
+    , defaultOpts
+    , setEqDerived
+    , setShowDerived
+    , setReadDerived
     ) where
 
 import Yesod.Routes.TH.Types
@@ -16,16 +27,67 @@ import Data.Text (pack)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Yesod.Routes.Class
 
+-- | General opts data type for generating yesod.
+--
+-- Contains options for what instances are derived for the route. Use the setting
+-- functions on `defaultOpts` to set specific fields.
+--
+-- @since 1.6.25.0
+data RouteOpts = MkRouteOpts
+    { roDerivedEq   :: Bool
+    , roDerivedShow :: Bool
+    , roDerivedRead :: Bool
+    }
+
+-- | Default options for generating routes.
+--
+-- Defaults to all instances derived.
+--
+-- @since 1.6.25.0
+defaultOpts :: RouteOpts
+defaultOpts = MkRouteOpts True True True
+
+-- |
+--
+-- @since 1.6.25.0
+setEqDerived :: Bool -> RouteOpts -> RouteOpts
+setEqDerived b rdo = rdo { roDerivedEq = b }
+
+-- |
+--
+-- @since 1.6.25.0
+setShowDerived :: Bool -> RouteOpts -> RouteOpts
+setShowDerived b rdo = rdo { roDerivedShow = b }
+
+-- |
+--
+-- @since 1.6.25.0
+setReadDerived :: Bool -> RouteOpts -> RouteOpts
+setReadDerived b rdo = rdo { roDerivedRead = b }
+
+-- |
+--
+-- @since 1.6.25.0
+instanceNamesFromOpts :: RouteOpts -> [Name]
+instanceNamesFromOpts (MkRouteOpts eq shw rd) = prependIf eq ''Eq $ prependIf shw ''Show $ prependIf rd ''Read []
+    where prependIf b = if b then (:) else const id
+
 -- | Generate the constructors of a route data type.
 mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])
-mkRouteCons rttypes =
+mkRouteCons = mkRouteConsOpts defaultOpts
+
+-- | Generate the constructors of a route data type, with custom opts.
+--
+-- @since 1.6.25.0
+mkRouteConsOpts :: RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])
+mkRouteConsOpts opts rttypes =
     mconcat <$> mapM mkRouteCon rttypes
   where
     mkRouteCon (ResourceLeaf res) =
         return ([con], [])
       where
         con = NormalC (mkName $ resourceName res)
-            $ map (\x -> (notStrict, x))
+            $ map (notStrict,)
             $ concat [singles, multi, sub]
         singles = concatMap toSingle $ resourcePieces res
         toSingle Static{} = []
@@ -39,16 +101,17 @@ mkRouteCons rttypes =
                 _ -> []
 
     mkRouteCon (ResourceParent name _check pieces children) = do
-        (cons, decs) <- mkRouteCons children
+        (cons, decs) <- mkRouteConsOpts opts children
+        let conts = mapM conT $ instanceNamesFromOpts opts
 #if MIN_VERSION_template_haskell(2,12,0)
-        dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq])
+        dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) conts
 #else
-        dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]
+        dec <- DataD [] (mkName name) [] Nothing cons <$> conts
 #endif
         return ([con], dec : decs)
       where
         con = NormalC (mkName name)
-            $ map (\x -> (notStrict, x))
+            $ map (notStrict,)
             $ singles ++ [ConT $ mkName name]
 
         singles = concatMap toSingle pieces
@@ -67,7 +130,7 @@ mkRenderRouteClauses =
         let cnt = length $ filter isDynamic pieces
         dyns <- replicateM cnt $ newName "dyn"
         child <- newName "child"
-        let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]
+        let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child]
 
         pack' <- [|pack|]
         tsp <- [|toPathPiece|]
@@ -100,7 +163,7 @@ mkRenderRouteClauses =
             case resourceDispatch res of
                 Subsite{} -> return <$> newName "sub"
                 _ -> return []
-        let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
+        let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub
 
         pack' <- [|pack|]
         tsp <- [|toPathPiece|]
@@ -152,9 +215,19 @@ mkRenderRouteClauses =
 -- 'renderRoute' method.  This function uses both 'mkRouteCons' and
 -- 'mkRenderRouteClasses'.
 mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
-mkRenderRouteInstance cxt typ ress = do
+mkRenderRouteInstance = mkRenderRouteInstanceOpts defaultOpts
+
+-- | Generate the 'RenderRoute' instance.
+--
+-- This includes both the 'Route' associated type and the
+-- 'renderRoute' method.  This function uses both 'mkRouteCons' and
+-- 'mkRenderRouteClasses'.
+--
+-- @since 1.6.25.0
+mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
+mkRenderRouteInstanceOpts opts cxt typ ress = do
     cls <- mkRenderRouteClauses ress
-    (cons, decs) <- mkRouteCons ress
+    (cons, decs) <- mkRouteConsOpts opts ress
 #if MIN_VERSION_template_haskell(2,15,0)
     did <- DataInstD [] Nothing (AppT (ConT ''Route) typ) Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
     let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
@@ -175,10 +248,17 @@ mkRenderRouteInstance cxt typ ress = do
           clazzes'
         else
           []
-    clazzes' = [''Show, ''Eq, ''Read]
+    clazzes' = instanceNamesFromOpts opts
 
 notStrict :: Bang
 notStrict = Bang NoSourceUnpackedness NoSourceStrictness
 
 instanceD :: Cxt -> Type -> [Dec] -> Dec
 instanceD = InstanceD Nothing
+
+conPCompat :: Name -> [Pat] -> Pat
+conPCompat n pats = ConP n
+#if MIN_VERSION_template_haskell(2,18,0)
+                         []
+#endif
+                         pats

yesod-core/src/Yesod/Routes/TH/RouteAttrs.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Routes.TH.RouteAttrs
@@ -26,7 +27,11 @@ goTree front (ResourceParent name _check pieces trees) =
     toIgnore = length $ filter isDynamic pieces
     isDynamic Dynamic{} = True
     isDynamic Static{} = False
-    front' = front . ConP (mkName name) . ignored
+    front' = front . ConP (mkName name)
+#if MIN_VERSION_template_haskell(2,18,0)
+                          []
+#endif
+                   . ignored
 
 goRes :: (Pat -> Pat) -> Resource a -> Q Clause
 goRes front Resource {..} =

yesod-core/test/RouteSpec.hs

@@ -227,7 +227,7 @@ main = hspec $ do
     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")
+                routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations.yesodroutes")
             length routes @?= 3
 
     describe "overlap checking" $ do

yesod-core/test/YesodCoreTest.hs

@@ -5,12 +5,16 @@ 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.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.JsLoader as JsLoader
@@ -40,9 +44,11 @@ specs = do
       mediaTest
       linksTest
       noOverloadedTest
+      subSubTest
       internalRequestTest
       errorHandlingTest
       cacheTest
+      parameterizedSiteTest
       WaiSubsite.specs
       Redirect.specs
       JsLoader.specs
@@ -59,3 +65,5 @@ specs = do
       Ssl.sslOnlySpec
       Ssl.sameSiteSpec
       Csrf.csrfSpec
+      breadcrumbTest
+      metaTest

yesod-core/test/YesodCoreTest/Breadcrumb.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module YesodCoreTest.Breadcrumb
+  ( breadcrumbTest,
+  )
+where
+
+import qualified Data.ByteString.Lazy.Char8 as L8
+import Data.Text (Text)
+import Data.Typeable (Typeable)
+import Network.Wai
+import Network.Wai.Test
+import Test.Hspec
+import UnliftIO.IORef
+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

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -1,26 +1,37 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+
 module YesodCoreTest.ErrorHandling
     ( errorHandlingTest
     , Widget
     , resourcesApp
     ) where
+
+import  Data.Typeable(cast)
+import qualified System.Mem as Mem
+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 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           UnliftIO.Exception(finally)
 import Network.HTTP.Types (Status, mkStatus)
 import Data.ByteString.Builder (Builder, toLazyByteString)
 import Data.Monoid (mconcat)
 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
 
@@ -45,6 +56,10 @@ mkYesod "App" [parseRoutes|
 /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
 |]
 
 overrideStatus :: Status
@@ -111,6 +126,23 @@ goodBuilderContent = Data.Monoid.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
@@ -154,6 +186,10 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       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 a -> IO a
 runner f = toWaiApp App >>= runSession f
@@ -291,3 +327,50 @@ caseVideoBadMethod = runner $ do
                 ("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.

yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+-- | a custom app that throws an exception
+module YesodCoreTest.ErrorHandling.CustomApp
+    (CustomApp(..)
+    , MyException(..)
+
+    -- * unused
+    , Widget
+    , resourcesCustomApp
+    ) where
+
+
+import Yesod.Core.Types
+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

yesod-core/test/YesodCoreTest/Meta.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+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

yesod-core/test/YesodCoreTest/ParameterizedSite.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+module YesodCoreTest.ParameterizedSite
+    ( parameterizedSiteTest
+    ) where
+
+import Data.ByteString.Lazy (ByteString)
+import Network.Wai.Test (runSession, request, defaultRequest, assertBodyContains)
+import Test.Hspec (Spec, describe, it)
+import Yesod.Core (YesodDispatch)
+import Yesod.Core.Dispatch (toWaiApp)
+
+import YesodCoreTest.ParameterizedSite.PolyAny (PolyAny (..))
+import YesodCoreTest.ParameterizedSite.PolyShow (PolyShow (..))
+import YesodCoreTest.ParameterizedSite.Compat (Compat (..))
+
+-- 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)
+    it "Polymorphic unconstrained stub, old-style" $ runStub (Compat () ())
+
+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

yesod-core/test/YesodCoreTest/ParameterizedSite/Compat.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE
+    TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
+  , OverloadedStrings, StandaloneDeriving, FlexibleInstances
+  #-}
+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
+    |]
+

yesod-core/test/YesodCoreTest/ParameterizedSite/PolyAny.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE
+    TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
+  , OverloadedStrings, StandaloneDeriving, FlexibleInstances
+  #-}
+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
+    |]
+

yesod-core/test/YesodCoreTest/ParameterizedSite/PolyShow.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE
+    TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
+  , OverloadedStrings, StandaloneDeriving, FlexibleInstances
+  #-}
+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}
+        |]
+

yesod-core/test/YesodCoreTest/SubSub.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+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

yesod-core/test/YesodCoreTest/SubSubData.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# 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
+|]

yesod-core/test/YesodCoreTest/Widget.hs

@@ -98,7 +98,7 @@ widgetTest = describe "Test.Widget" $ do
     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

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.18.1
+version:         1.6.25.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -8,7 +8,7 @@ synopsis:        Creation of type-safe, RESTful web applications.
 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:
@@ -17,15 +17,17 @@ extra-source-files:
   test/YesodCoreTest/JsLoaderSites/Bottom.hs
   test/en.msg
   test/test.hs
-  test/fixtures/routes_with_line_continuations
+  test/fixtures/routes_with_line_continuations.yesodroutes
   ChangeLog.md
   README.md
 
 library
+    default-language: Haskell2010
     hs-source-dirs: src
 
     build-depends:   base                  >= 4.10     && < 5
                    , aeson                 >= 1.0
+                   , attoparsec-aeson      >= 2.1
                    , auto-update
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.7.1
@@ -38,6 +40,7 @@ library
                    , containers            >= 0.2
                    , cookie                >= 0.4.3    && < 0.5
                    , deepseq               >= 1.3
+                   , entropy
                    , fast-logger           >= 2.2
                    , http-types            >= 0.7
                    , memory
@@ -46,7 +49,7 @@ library
                    , parsec                >= 2        && < 3.2
                    , path-pieces           >= 0.1.2    && < 0.3
                    , primitive             >= 0.6
-                   , random                >= 1.0.0.2  && < 1.2
+                   , random                >= 1.0.0.2  && < 1.3
                    , resourcet             >= 1.2
                    , shakespeare           >= 2.0
                    , template-haskell      >= 2.11
@@ -56,7 +59,7 @@ library
                    , unix-compat
                    , unliftio
                    , unordered-containers  >= 0.2
-                   , vector                >= 0.9      && < 0.13
+                   , vector                >= 0.9      && < 0.14
                    , wai                   >= 3.2
                    , wai-extra             >= 3.0.7
                    , wai-logger            >= 0.2
@@ -97,14 +100,12 @@ library
                      Yesod.Routes.TH.RouteAttrs
 
     ghc-options:     -Wall
-    -- Following line added due to: https://github.com/yesodweb/yesod/issues/545
-    -- This looks like a GHC bug
-    extensions:      MultiParamTypeClasses
 
     -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
-    extensions:      TemplateHaskell
+    other-extensions:      TemplateHaskell
 
 test-suite test-routes
+    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: RouteSpec.hs
     hs-source-dirs: test, src
@@ -121,7 +122,7 @@ test-suite test-routes
                    Yesod.Routes.TH.Types
 
     -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
-    extensions:      TemplateHaskell
+    other-extensions:      TemplateHaskell
 
     build-depends: base
                  , hspec
@@ -134,6 +135,7 @@ test-suite test-routes
                  , HUnit
 
 test-suite tests
+    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: test.hs
     hs-source-dirs: test
@@ -145,6 +147,7 @@ test-suite tests
                    YesodCoreTest.Header
                    YesodCoreTest.Csrf
                    YesodCoreTest.ErrorHandling
+                   YesodCoreTest.ErrorHandling.CustomApp
                    YesodCoreTest.Exceptions
                    YesodCoreTest.InternalRequest
                    YesodCoreTest.JsLoader
@@ -154,8 +157,13 @@ test-suite tests
                    YesodCoreTest.LiteApp
                    YesodCoreTest.Media
                    YesodCoreTest.MediaData
+                   YesodCoreTest.Meta
                    YesodCoreTest.NoOverloadedStrings
                    YesodCoreTest.NoOverloadedStringsSub
+                   YesodCoreTest.ParameterizedSite
+                   YesodCoreTest.ParameterizedSite.Compat
+                   YesodCoreTest.ParameterizedSite.PolyAny
+                   YesodCoreTest.ParameterizedSite.PolyShow
                    YesodCoreTest.RawResponse
                    YesodCoreTest.Redirect
                    YesodCoreTest.Reps
@@ -166,6 +174,8 @@ test-suite tests
                    YesodCoreTest.StubSslOnly
                    YesodCoreTest.StubStrictSameSite
                    YesodCoreTest.StubUnsecured
+                   YesodCoreTest.SubSub
+                   YesodCoreTest.SubSubData
                    YesodCoreTest.WaiSubsite
                    YesodCoreTest.Widget
                    YesodCoreTest.YesodTest
@@ -197,9 +207,10 @@ test-suite tests
                   , warp
                   , yesod-core
     ghc-options:     -Wall -threaded
-    extensions: TemplateHaskell
+    other-extensions: TemplateHaskell
 
 benchmark widgets
+    default-language: Haskell2010
     type: exitcode-stdio-1.0
     hs-source-dirs: bench
     build-depends:  base

yesod-eventsource/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.6.0.1
+
+* Update documentation from `HandlerT` to `HandlerFor` [#1703](https://github.com/yesodweb/yesod/pull/1703)
+
 ## 1.6.0
 
 * Upgrade to yesod-core 1.6.0

yesod-eventsource/Yesod/EventSource.hs

@@ -63,9 +63,9 @@ sourceToSource src =
             Just x -> yield (Chunk x) >> yield Flush
 
 
--- | Return a Server-Sent Event stream given a 'HandlerT' action
+-- | Return a Server-Sent Event stream given a 'HandlerFor' action
 -- that is repeatedly called.  A state is threaded for the action
--- so that it may avoid using @IORefs@.  The @HandlerT@ action
+-- so that it may avoid using @IORefs@.  The @HandlerFor@ action
 -- may sleep or block while waiting for more data.  The HTTP
 -- socket is flushed after every list of simultaneous events.
 -- The connection is closed as soon as an 'ES.CloseEvent' is

yesod-eventsource/yesod-eventsource.cabal

@@ -1,5 +1,6 @@
+cabal-version:   >= 1.10
 name:            yesod-eventsource
-version:         1.6.0
+version:         1.6.0.1
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa <felipe.lessa@gmail.com>
@@ -7,13 +8,13 @@ maintainer:      Felipe Lessa <felipe.lessa@gmail.com>
 synopsis:        Server-sent events support for Yesod apps.
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.6
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-eventsource>
 extra-source-files: README.md ChangeLog.md
 
 library
+    default-language: Haskell2010
     build-depends:   base                  >= 4.10     && < 5
                    , blaze-builder
                    , conduit               >= 1.3

yesod-form-multi/ChangeLog.md

@@ -1,5 +1,30 @@
 # Changelog
 
+## 1.7.0.2
+
+* Allow yesod-form 1.7
+
+## 1.7.0.1
+
+[#1716](https://github.com/yesodweb/yesod/pull/1716)
+
+* Fixed bug where duplicating `<option>` tags caused the `value` field to be cleared
+
+## 1.7.0
+
+[#1707](https://github.com/yesodweb/yesod/pull/1707)
+
+* Added delete buttons
+* Added support for custom text or icons inside add/delete buttons
+* Added new presets for Bootstrap + Font Awesome icons
+* Added support for more complex fields that have multiple parts stuch as radio fields
+* Improved support for fields that rely on hidden inputs like WYSIWYG editors
+* Fixed redundant class in existing Bootstrap presets
+* Fixed styling not applying to error messages on individual fields
+* Tooltips now show once at the top of the multi-field group when using `amulti`
+
 ## 1.6.0
 
-* Added `Yesod.Form.MultiInput` which supports multi-input forms without needing to submit the form to add an input field [#1601](https://github.com/yesodweb/yesod/pull/1601)
+[#1601](https://github.com/yesodweb/yesod/pull/1601)
+
+* Added `Yesod.Form.MultiInput` which supports multi-input forms without needing to submit the form to add an input field

yesod-form-multi/README.md

@@ -1,7 +1,5 @@
 ## yesod-form-multi
 
 Support for creating forms in which the user can specify how many inputs to submit. Includes support for enforcing a minimum number of values.
-Intended as an alternative to `Yesod.Form.MassInput`.
 
-# Limitations
+Intended as an alternative to `Yesod.Form.MassInput`.
-- If the user adds too many fields then there is currently no support for a "delete button" although fields submitted empty are considered to be deleted.

yesod-form-multi/Yesod/Form/MultiInput.hs

@@ -17,16 +17,19 @@ module Yesod.Form.MultiInput
     , mmulti
     , amulti
     , bs3Settings
+    , bs3FASettings
     , bs4Settings
+    , bs4FASettings
     ) where
 
 import Control.Arrow (second)
 import Control.Monad (liftM)
 import Control.Monad.Trans.RWS (ask, tell)
 import qualified Data.Map as Map
-import Data.Maybe (fromJust, listToMaybe, fromMaybe)
+import Data.Maybe (fromJust, listToMaybe, fromMaybe, isJust)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Text.Julius (rawJS)
 import Yesod.Core
 import Yesod.Form.Fields (intField)
 import Yesod.Form.Functions
@@ -41,43 +44,132 @@ instance ToJavascript Text where toJavascript = toJavascript . toJSON
 #endif
 #endif
 
--- @since 1.6.0
+-- | By default delete buttons have a @margin-left@ property of @0.75rem@.
+-- You can override this by specifying an alternative value in a class
+-- which is then passed inside 'MultiSettings'.
+--
+-- @since 1.7.0
 data MultiSettings site = MultiSettings
-    { msAddClass :: Text -- ^ Class to be applied to the "add another" button.
+    { msAddClass :: !Text -- ^ Class to be applied to the "add another" button.
+    , msDelClass :: !Text -- ^ Class to be applied to the "delete" button.
+    , msTooltipClass :: Text -- ^ Only used in applicative forms. Class to be applied to the tooltip.
+    , msWrapperErrClass :: !Text -- ^ Class to be applied to the wrapper if it's field has an error.
+    , msAddInner :: !(Maybe Html) -- ^ Inner Html of add button, defaults to "Add Another". Useful for adding icons inside buttons.
+    , msDelInner :: !(Maybe Html) -- ^ Inner Html of delete button, defaults to "Delete". Useful for adding icons inside buttons.
     , msErrWidget :: Maybe (Html -> WidgetFor site ()) -- ^ Only used in applicative forms. Create a widget for displaying errors.
     }
 
--- @since 1.6.0
+-- | The general structure of each individually generated field is as follows.
+-- There is an external wrapper element containing both an inner wrapper and any
+-- error messages that apply to that specific field. The inner wrapper contains
+-- both the field and it's corresponding delete button.
+--
+-- The structure is illustrated by the following:
+-- 
+-- > <div .#{wrapperClass}>
+-- >     <div .#{wrapperClass}-inner>
+-- >         ^{fieldWidget}
+-- >         ^{deleteButton}
+-- >     ^{maybeErrorMessages}
+--
+-- Each wrapper element has the same class which is automatically generated. This class
+-- is returned in the 'MultiView' should you wish to change the styling. The inner wrapper
+-- uses the same class followed by @-inner@. By default the wrapper and inner wrapper has
+-- classes are as follows:
+-- 
+-- > .#{wrapperClass} {
+-- >     margin-bottom: 1rem;
+-- > }
+-- >
+-- > .#{wrapperClass}-inner {
+-- >     display: flex;
+-- >     flex-direction: row;
+-- > }
+--
+-- @since 1.7.0
 data MultiView site = MultiView
     { mvCounter :: FieldView site -- ^ Hidden counter field.
     , mvFields :: [FieldView site] -- ^ Input fields.
     , mvAddBtn :: FieldView site -- ^ Button to add another field.
+    , mvWrapperClass :: Text -- ^ Class applied to a div wrapping each field with it's delete button.
     }
 
 -- | 'MultiSettings' for Bootstrap 3.
 --
 -- @since 1.6.0
 bs3Settings :: MultiSettings site
-bs3Settings = MultiSettings "btn btn-default" (Just errW)
+bs3Settings = MultiSettings
+    "btn btn-default"
+    "btn btn-danger"
+    "help-block"
+    "has-error"
+    Nothing Nothing (Just errW)
     where
         errW err = 
             [whamlet|
-                <span .help-block .error-block>#{err}
+                <span .help-block>#{err}
             |]
 
 -- | 'MultiSettings' for Bootstrap 4.
 --
 -- @since 1.6.0
 bs4Settings :: MultiSettings site
-bs4Settings = MultiSettings "btn btn-basic" (Just errW)
+bs4Settings = MultiSettings
+    "btn btn-secondary"
+    "btn btn-danger"
+    "form-text text-muted"
+    "has-error"
+    Nothing Nothing (Just errW)
     where
         errW err =
             [whamlet|
                 <div .invalid-feedback>#{err}
             |]
 
+-- | 'MultiSettings' for Bootstrap 3 with Font Awesome 5 Icons.
+-- Uses @fa-plus@ for the add button and @fa-trash-alt@ for the delete button.
+--
+-- @since 1.7.0
+bs3FASettings :: MultiSettings site
+bs3FASettings = MultiSettings
+    "btn btn-default"
+    "btn btn-danger"
+    "help-block"
+    "has-error"
+    addIcon delIcon (Just errW)
+    where
+        addIcon = Just [shamlet|<i class="fas fa-plus">|]
+        delIcon = Just [shamlet|<i class="fas fa-trash-alt">|]
+        errW err = 
+            [whamlet|
+                <span .help-block>#{err}
+            |]
+
+-- | 'MultiSettings' for Bootstrap 4 with Font Awesome 5 Icons.
+-- Uses @fa-plus@ for the add button and @fa-trash-alt@ for the delete button.
+--
+-- @since 1.7.0
+bs4FASettings :: MultiSettings site
+bs4FASettings = MultiSettings
+    "btn btn-secondary"
+    "btn btn-danger"
+    "form-text text-muted"
+    "has-error"
+    addIcon delIcon (Just errW)
+    where
+        addIcon = Just [shamlet|<i class="fas fa-plus">|]
+        delIcon = Just [shamlet|<i class="fas fa-trash-alt">|]
+        errW err =
+            [whamlet|
+                <div .invalid-feedback>#{err}
+            |]
+
 -- | Applicative equivalent of 'mmulti'.
 --
+-- Note about tooltips:
+-- Rather than displaying the tooltip alongside each field the
+-- tooltip is displayed once at the top of the multi-field set.
+--
 -- @since 1.6.0
 amulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
     => Field m a
@@ -92,20 +184,19 @@ amulti field fs defs minVals ms = formToAForm $
         mform = do
             (fr, MultiView {..}) <- mmulti field fs defs minVals ms
 
-            let widget = do
+            let (fv : _) = mvFields
+                widget = do
                     [whamlet|
+                        $maybe tooltip <- fvTooltip fv
+                            <small .#{msTooltipClass ms}>#{tooltip}
+
                         ^{fvInput mvCounter}
 
                         $forall fv <- mvFields
                             ^{fvInput fv}
 
-                            $maybe err <- fvErrors fv
-                                $maybe errW <- msErrWidget ms
-                                    ^{errW err}
-
                         ^{fvInput mvAddBtn}
                     |]
-                (fv : _) = mvFields
                 view = FieldView
                     { fvLabel = fvLabel fv
                     , fvTooltip = Nothing
@@ -130,11 +221,10 @@ mmulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
     -> Int
     -> MultiSettings site
     -> MForm m (FormResult [a], MultiView site)
-mmulti field fs@FieldSettings {..} defs minVals ms = do
+mmulti field fs defs minVals' ms = do
-    fieldClass <- newFormIdent
+    wrapperClass <- lift newIdent
-    let fs' = fs {fsAttrs = addClass fieldClass fsAttrs}
+    let minVals = if minVals' < 0 then 0 else minVals'
-        minVals' = if minVals < 0 then 0 else minVals
+    mhelperMulti field fs wrapperClass defs minVals ms
-    mhelperMulti field fs' fieldClass defs minVals' ms
 
 -- Helper function, does most of the work for mmulti.
 mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
@@ -145,21 +235,22 @@ mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMe
     -> Int
     -> MultiSettings site
     -> MForm m (FormResult [a], MultiView site)
-mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals MultiSettings {..} = do
+mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals MultiSettings {..} = do
     mp <- askParams
     (_, site, langs) <- ask
     name <- maybe newFormIdent return fsName
-    theId <- maybe newFormIdent return fsId
+    theId <- lift $ maybe newIdent return fsId
     cName <- newFormIdent
-    cid <- newFormIdent
+    cid <- lift newIdent
-    addBtnId <- newFormIdent 
+    addBtnId <- lift newIdent
+    delBtnPrefix <- lift newIdent
 
     let mr2 = renderMessage site langs
         cDef = length defs
         cfs = FieldSettings "" Nothing (Just cid) (Just cName) [("hidden", "true")]
         mkName i = name `T.append` (T.pack $ '-' : show i)
         mkId i = theId `T.append` (T.pack $ '-' : show i)
-        mkNames c = [(mkName i, mkId i) | i <- [0 .. c]]
+        mkNames c = [(i, (mkName i, mkId i)) | i <- [0 .. c]]
         onMissingSucc _ _ = FormSuccess Nothing
         onMissingFail m l = FormFailure [renderMessage m l MsgValueRequired]
         isSuccNothing r = case r of
@@ -174,7 +265,7 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals Mult
         Just p -> mkRes intField cfs p mfs cName onMissingFail FormSuccess
 
     -- generate counter view
-    cView <- mkView intField cfs cr cid cName True
+    cView <- mkView intField cfs cr Nothing Nothing msWrapperErrClass cid cName True
 
     let counter = case cRes of
             FormSuccess c -> c
@@ -186,17 +277,74 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals Mult
             if cDef == 0
                 then [(FormMissing, Left "")]
                 else [(FormMissing, Right d) | d <- defs]
-        Just p -> mapM (\n -> mkRes field fs p mfs n onMissingSucc (FormSuccess . Just)) (map fst $ mkNames counter)
+        Just p -> mapM
+            (\n -> mkRes field fs p mfs n onMissingSucc (FormSuccess . Just))
+            (map (fst . snd) $ mkNames counter)
+
+    -- delete button
+
+    -- The delFunction is included down with the add button rather than with
+    -- each delete button to ensure that the function only gets included once.
+    let delFunction = toWidget
+            [julius|
+                function deleteField_#{rawJS theId}(wrapper) {
+                    var numFields = $('.#{rawJS wrapperClass}').length;
+
+                    if (numFields == 1)
+                    {
+                        wrapper.find("*").each(function() {
+                            removeVals($(this));
+                        });
+                    }
+                    else
+                        wrapper.remove();
+                }
+
+                function removeVals(e) {
+                    // input types where we don't want to reset the value
+                    const keepValueTypes = ["radio", "checkbox", "button"];
+
+                    var shouldKeep = keepValueTypes.includes(e.prop('type'))
+                                        || e.prop("tagName") == "OPTION";
+
+                    // uncheck any checkboxes or radio fields and empty any text boxes
+                    if(e.prop('checked') == true)
+                        e.prop('checked', false);
+
+                    if(!shouldKeep)
+                        e.val("").trigger("change");
+                        // trigger change is to ensure WYSIWYG editors are updated
+                        // when their hidden code field is cleared
+                }
+            |]
+
+        mkDelBtn fieldId = do
+            let delBtnId = delBtnPrefix `T.append` fieldId
+            [whamlet|
+                <button ##{delBtnId} .#{msDelClass} style="margin-left: 0.75rem" type="button">
+                    $maybe inner <- msDelInner
+                        #{inner}
+                    $nothing
+                        Delete
+            |]
+            toWidget
+                [julius|
+                    $('##{rawJS delBtnId}').click(function() {
+                        var field = $('##{rawJS fieldId}');
+                        deleteField_#{rawJS theId}(field.parents('.#{rawJS wrapperClass}'));
+                    });                    
+                |]
 
     -- generate field views
     (rs, fvs) <- do
-        let mkView' ((n,i), r@(res, _)) = do
+        let mkView' ((c, (n,i)), r@(res, _)) = do
-                fv <- mkView field fs r i n False
+                let del = Just (mkDelBtn i, wrapperClass, c)
+                fv <- mkView field fs r del msErrWidget msWrapperErrClass i n True
                 return (res, fv)
             xs = zip (mkNames counter) results
             notSuccNothing (_, (r,_)) = not $ isSuccNothing r
             ys = case filter notSuccNothing xs of
-                [] -> [((mkName 0, mkId 0), (FormSuccess Nothing, Left ""))] -- always need at least one value to generate a field
+                [] -> [((0, (mkName 0, mkId 0)), (FormSuccess Nothing, Left ""))] -- always need at least one value to generate a field
                 zs -> zs
         rvs <- mapM mkView' ys
         return $ unzip rvs
@@ -214,23 +362,77 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals Mult
                 fRes -> (fRes, False)
     
         -- create add button
+        -- also includes some styling / functions that we only want to include once
         btnWidget = do
             [whamlet|
-                <button ##{addBtnId} .#{msAddClass} type="button">Add Another
+                <button ##{addBtnId} .#{msAddClass} type="button">
+                    $maybe inner <- msAddInner
+                        #{inner}
+                    $nothing
+                        Add Another
             |]
+            toWidget
+                [lucius|
+                    .#{wrapperClass} {
+                        margin-bottom: 1rem;
+                    }
+                    .#{wrapperClass}-inner {
+                        display: flex;
+                        flex-direction: row;
+                    }
+                |]
+            delFunction -- function used by delete buttons, included here so that it only gets included once
             toWidget
                 [julius|
-                    var extraFields = 0;
+                    var extraFields_#{rawJS theId} = 0;
-                    $("#" + #{addBtnId}).click(function() {
+                    $('##{rawJS addBtnId}').click(function() {
-                        extraFields++;
+                        extraFields_#{rawJS theId}++;
-                        var newNumber = parseInt(#{show counter}) + extraFields;
+                        var newNumber = parseInt(#{show counter}) + extraFields_#{rawJS theId};
                         $("#" + #{cid}).val(newNumber);
                         var newName = #{name} + "-" + newNumber;
                         var newId = #{theId} + "-" + newNumber;
+                        var newDelId = #{delBtnPrefix} + newId;
                         
-                        var newElem = $("." + #{fieldClass}).first().clone();
+                        // get new wrapper and remove old error messages
-                        newElem.val("").attr('name', newName).attr('id', newId);
+                        var newWrapper = $('.#{rawJS wrapperClass}').first().clone();
-                        newElem.insertBefore("#" + #{addBtnId})
+                        newWrapper.children( ':not(.#{rawJS wrapperClass}-inner)' ).remove();
+                        newWrapper.removeClass(#{msWrapperErrClass});
+
+                        // get counter from wrapper
+                        var oldCount = newWrapper.data("counter");
+                        var oldName = #{name} + "-" + oldCount;
+                        var oldId = #{theId} + "-" + oldCount;
+                        var oldDelBtn = #{delBtnPrefix} + oldId;
+
+                        // replace any id, name or for attributes that began with
+                        // the old values and replace them with the new values
+                        var idRegex = new RegExp("^" + oldId);
+                        var nameRegex = new RegExp("^" + oldName);
+
+                        var els = newWrapper.find("*");
+                        els.each(function() {
+                            var e = $(this);
+
+                            if(e.prop('id') != undefined)
+                                e.prop('id', e.prop('id').replace(idRegex, newId));
+
+                            if(e.prop('name') != undefined)
+                                e.prop('name', e.prop('name').replace(nameRegex, newName));
+
+                            if(e.prop('for') != undefined)
+                                e.prop('for', e.prop('for').replace(idRegex, newId)); // radio fields use id in for attribute
+
+                            removeVals(e);
+                        });
+
+                        // set new counter on wrapper
+                        newWrapper.attr("data-counter", newNumber);
+
+                        var newDelBtn = newWrapper.find('[id^=#{rawJS delBtnPrefix}]');
+                        newDelBtn.prop('id', newDelId);
+                        newDelBtn.click(() => deleteField_#{rawJS theId}(newWrapper));
+
+                        newWrapper.insertBefore('##{rawJS addBtnId}');
                     });
                 |]
 
@@ -243,7 +445,7 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals Mult
             , fvRequired = False
             }
 
-    return (res, MultiView cView fvs btnView)
+    return (res, MultiView cView fvs btnView wrapperClass)
 
 -- Search for the given field's name in the environment,
 -- parse any values found and construct a FormResult.
@@ -274,21 +476,42 @@ mkView :: (site ~ HandlerSite m, MonadHandler m)
     => Field m a
     -> FieldSettings site
     -> (FormResult b, Either Text a)
+    -- Delete button widget, class for div wrapping each field with it's delete button and counter value for that field.
+    -- Nothing if the field passed doesn't need a delete button e.g. if it is the counter field.
+    -> Maybe (WidgetFor site (), Text, Int)
+    -> Maybe (Html -> WidgetFor site ()) -- Function to display error messages.
+    -> Text
     -> Text
     -> Text
     -> Bool
     -> MForm m (FieldView site)
-mkView Field {..} FieldSettings {..} (res, val) theId name isReq = do
+mkView Field {..} FieldSettings {..} (res, val) mdel merrW errClass theId name isReq = do
     (_, site, langs) <- ask
     let mr2 = renderMessage site langs
+        merr = case res of
+                FormFailure [e] -> Just $ toHtml e
+                _ -> Nothing
+        fv' = fieldView theId name fsAttrs val isReq
+        fv = do
+            [whamlet|
+                $maybe (delBtn, wrapperClass, counter) <- mdel
+                    <div .#{wrapperClass} :isJust merr:.#{errClass} data-counter=#{counter}>
+                        <div .#{wrapperClass}-inner>
+                            ^{fv'}
+                            ^{delBtn}
+                            
+                        $maybe err <- merr
+                            $maybe errW <- merrW
+                                ^{errW err}
+                        
+                $nothing
+                    ^{fv'}
+            |]
     return $ FieldView
         { fvLabel = toHtml $ mr2 fsLabel
         , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
         , fvId = theId
-        , fvInput = fieldView theId name fsAttrs val isReq
+        , fvInput = fv
-        , fvErrors =
+        , fvErrors = merr
-            case res of
-                FormFailure [e] -> Just $ toHtml e
-                _ -> Nothing
         , fvRequired = isReq
         }

yesod-form-multi/yesod-form-multi.cabal

@@ -1,5 +1,5 @@
 name:            yesod-form-multi
-version:         1.6.0
+version:         1.7.0.2
 license:         MIT
 license-file:    LICENSE
 author:          James Burton <jamesejburton@gmail.com>
@@ -7,7 +7,7 @@ maintainer:      James Burton <jamesejburton@gmail.com>
 synopsis:        Multi-input form handling for Yesod Web Framework
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.8
+cabal-version:   >= 1.10
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-form-multi>.
@@ -19,13 +19,14 @@ flag network-uri
   default: True
 
 library
+    default-language: Haskell2010
     build-depends:   base                  >= 4.10     && < 5
                    , containers            >= 0.2
                    , shakespeare           >= 2.0
                    , text                  >= 0.9
                    , transformers          >= 0.2.2
                    , yesod-core            >= 1.6      && < 1.7
-                   , yesod-form            >= 1.6      && < 1.7
+                   , yesod-form            >= 1.6      && < 1.8
 
     if flag(network-uri)
       build-depends: network-uri >= 2.6

yesod-form/ChangeLog.md

@@ -1,5 +1,33 @@
 # ChangeLog for yesod-form
 
+## 1.7.6
+
+* Added `datetimeLocalField` for creating a html `<input type="datetime-local">` [#1817](https://github.com/yesodweb/yesod/pull/1817)
+
+## 1.7.5
+
+* Add Romanian translation [#1801](https://github.com/yesodweb/yesod/pull/1801)
+
+## 1.7.4
+
+* Added a `Monad AForm` instance only when `transformers` >= 0.6 [#1795](https://github.com/yesodweb/yesod/pull/1795)
+
+## 1.7.3
+
+* Fixed `radioField` according to Bootstrap 3 docs. [#1783](https://github.com/yesodweb/yesod/pull/1783)
+
+## 1.7.2
+
+* Added `withRadioField` and re-express `radioField` into that. [#1775](https://github.com/yesodweb/yesod/pull/1775)
+
+## 1.7.1
+
+* Added `colorField` for creating a html color field (`<input type="color">`) [#1748](https://github.com/yesodweb/yesod/pull/1748)
+
+## 1.7.0
+
+* Extended `OptionList` by `OptionListGrouped` and implemented grouped select fields (`<select>` with `<optgroup>`) [#1722](https://github.com/yesodweb/yesod/pull/1722)
+
 ## 1.6.7
 
 * Added equivalent version of `mreqMsg` for `areq` and `wreq` correspondingly [#1628](https://github.com/yesodweb/yesod/pull/1628)

yesod-form/README.md

@@ -3,7 +3,7 @@
 Form handling for Yesod, in the same style as formlets. See [the forms
 chapter](http://www.yesodweb.com/book/forms) of the Yesod book.
 
-This package provies a set of basic form inputs such as text, number, time,
+This package provides a set of basic form inputs such as text, number, time,
 checkbox, select, textarea, and etc. via `Yesod.Form.Fields` module.  Also,
 there is `Yesod.Form.Nic` module providing richtext field using Nic editor.
 However, this module is grandfathered now and Nic editor is not actively

yesod-form/Yesod/Form/Fields.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE CPP #-}
 -- | Field functions allow you to easily create and validate forms, cleanly handling the uncertainty of parsing user input.
@@ -45,8 +46,10 @@ module Yesod.Form.Fields
     , selectFieldHelper
     , selectField
     , selectFieldList
+    , selectFieldListGrouped
     , radioField
     , radioFieldList
+    , withRadioField
     , checkboxesField
     , checkboxesFieldList
     , multiSelectField
@@ -54,10 +57,14 @@ module Yesod.Form.Fields
     , Option (..)
     , OptionList (..)
     , mkOptionList
+    , mkOptionListGrouped
     , optionsPersist
     , optionsPersistKey
     , optionsPairs
+    , optionsPairsGrouped
     , optionsEnum
+    , colorField
+    , datetimeLocalField
     ) where
 
 import Yesod.Form.Types
@@ -68,7 +75,7 @@ import Text.Blaze (ToMarkup (toMarkup), unsafeByteString)
 #define ToHtml ToMarkup
 #define toHtml toMarkup
 #define preEscapedText preEscapedToMarkup
-import Data.Time (Day, TimeOfDay(..))
+import Data.Time (Day, TimeOfDay(..), LocalTime (LocalTime))
 import qualified Text.Email.Validate as Email
 import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
@@ -80,7 +87,7 @@ import Database.Persist (Entity (..), SqlType (SqlString), PersistRecordBackend,
 import Database.Persist (Entity (..), SqlType (SqlString), PersistEntity, PersistQuery, PersistEntityBackend)
 #endif
 import Text.HTML.SanitizeXSS (sanitizeBalance)
-import Control.Monad (when, unless)
+import Control.Monad (when, unless, forM_)
 import Data.Either (partitionEithers)
 import Data.Maybe (listToMaybe, fromMaybe)
 
@@ -92,7 +99,8 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
 import Data.Text as T ( Text, append, concat, cons, head
-                      , intercalate, isPrefixOf, null, unpack, pack, splitOn
+                      , intercalate, isPrefixOf, null, unpack, pack
+                      , split, splitOn
                       )
 import qualified Data.Text as T (drop, dropWhile)
 import qualified Data.Text.Read
@@ -113,6 +121,8 @@ import Data.String (IsString)
 import Data.Monoid
 #endif
 
+import Data.Char (isHexDigit)
+
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
 
@@ -172,7 +182,7 @@ timeField = timeFieldTypeTime
 --
 -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
 --
--- Since 1.4.2
+-- @since 1.4.2
 timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
 timeFieldTypeTime = timeFieldOfType "time"
 
@@ -182,7 +192,7 @@ timeFieldTypeTime = timeFieldOfType "time"
 --
 -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
 --
--- Since 1.4.2
+-- @since 1.4.2
 timeFieldTypeText :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
 timeFieldTypeText = timeFieldOfType "text"
 
@@ -362,7 +372,7 @@ $newline never
 
 -- | Creates an input with @type="email"@ with the <http://w3c.github.io/html/sec-forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'.
 --
--- Since 1.3.7
+-- @since 1.3.7
 multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
 multiEmailField = Field
     { fieldParse = parseHelper $
@@ -427,7 +437,15 @@ selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg
                 -> Field (HandlerFor site) a
 selectFieldList = selectField . optionsPairs
 
--- | Creates a @\<select>@ tag for selecting one option. Example usage:
+-- | Creates a @\<select>@ tag with @\<optgroup>@s for selecting one option.
+--
+-- @since 1.7.0
+selectFieldListGrouped :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
+                => [(msg, [(msg, a)])]
+                -> Field (HandlerFor site) a
+selectFieldListGrouped = selectField . optionsPairsGrouped
+
+-- | Creates a @\<select>@ tag with optional @\<optgroup>@s for selecting one option. Example usage:
 --
 -- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing
 selectField :: (Eq a, RenderMessage site FormMessage)
@@ -446,6 +464,9 @@ $newline never
 $newline never
 <option value=#{value} :isSel:selected>#{text}
 |]) -- inside
+    (Just $ \label -> [whamlet|
+<optgroup label=#{label}>
+|]) -- group label
 
 -- | Creates a @\<select>@ tag for selecting multiple options.
 multiSelectFieldList :: (Eq a, RenderMessage site msg)
@@ -512,25 +533,52 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
 radioField :: (Eq a, RenderMessage site FormMessage)
            => HandlerFor site (OptionList a)
            -> Field (HandlerFor site) a
-radioField = selectFieldHelper
+radioField = withRadioField
-    (\theId _name _attrs inside -> [whamlet|
+    (\theId optionWidget -> [whamlet|
 $newline never
-<div ##{theId}>^{inside}
+<div .radio>
+    <label for=#{theId}-none>
+        <div>
+            ^{optionWidget}
+            _{MsgSelectNone}
 |])
-    (\theId name isSel -> [whamlet|
+    (\theId value _isSel text optionWidget -> [whamlet|
 $newline never
-<label .radio for=#{theId}-none>
+<div .radio>
-    <div>
+    <label for=#{theId}-#{value}>
-        <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
+        <div>
-        _{MsgSelectNone}
+            ^{optionWidget}
+            \#{text}
 |])
-    (\theId name attrs value isSel text -> [whamlet|
+
+
+-- | Allows the user to place the option radio widget somewhere in
+--   the template.
+--   For example: If you want a table of radio options to select.
+--   'radioField' is an example on how to use this function.
+--
+--   @since 1.7.2
+withRadioField :: (Eq a, RenderMessage site FormMessage)
+           => (Text -> WidgetFor site ()-> WidgetFor site ()) -- ^ nothing case for mopt
+           -> (Text ->  Text -> Bool -> Text -> WidgetFor site () -> WidgetFor site ()) -- ^ cases for values
+           -> HandlerFor site (OptionList a)
+           -> Field (HandlerFor site) a
+withRadioField nothingFun optFun =
+  selectFieldHelper outside onOpt inside Nothing
+  where
+    outside theId _name _attrs inside' = [whamlet|
 $newline never
-<label .radio for=#{theId}-#{value}>
+<div ##{theId}>^{inside'}
-    <div>
+|]
-        <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
+    onOpt theId name isSel = nothingFun theId $ [whamlet|
-        \#{text}
+$newline never
-|])
+<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
+|]
+    inside theId name attrs value isSel display =
+       optFun theId value isSel display [whamlet|
+<input id=#{theId}-#{(value)} type=radio name=#{name} value=#{(value)} :isSel:checked *{attrs}>
+|]
+
 
 -- | Creates a group of radio buttons to answer the question given in the message. Radio buttons are used to allow differentiating between an empty response (@Nothing@) and a no response (@Just False@). Consider using the simpler 'checkBoxField' if you don't need to make this distinction.
 --
@@ -598,15 +646,31 @@ $newline never
         showVal = either (\_ -> False)
 
 -- | A structure holding a list of options. Typically you can use a convenience function like 'mkOptionList' or 'optionsPairs' instead of creating this directly.
-data OptionList a = OptionList
+--
+-- Extended by 'OptionListGrouped' in 1.7.0.
+data OptionList a
+  = OptionList
     { olOptions :: [Option a]
     , olReadExternal :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue').
     }
+  | OptionListGrouped
+    { olOptionsGrouped :: [(Text, [Option a])]
+    , olReadExternalGrouped :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue').
+    }
 
--- | Since 1.4.6
+-- | Convert grouped 'OptionList' to a normal one.
+--
+-- @since 1.7.0
+flattenOptionList :: OptionList a -> OptionList a
+flattenOptionList (OptionListGrouped os re) = OptionList (concatMap snd os) re
+flattenOptionList ol = ol
+
+-- | @since 1.4.6
 instance Functor OptionList where
     fmap f (OptionList options readExternal) =
       OptionList ((fmap.fmap) f options) (fmap f . readExternal)
+    fmap f (OptionListGrouped options readExternal) =
+      OptionListGrouped (map (\(g, os) -> (g, (fmap.fmap) f os)) options) (fmap f . readExternal)
 
 -- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternal' function.
 mkOptionList :: [Option a] -> OptionList a
@@ -615,13 +679,22 @@ mkOptionList os = OptionList
     , olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os
     }
 
+-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternalGrouped' function.
+--
+-- @since 1.7.0
+mkOptionListGrouped :: [(Text, [Option a])] -> OptionList a
+mkOptionListGrouped os = OptionListGrouped
+    { olOptionsGrouped = os
+    , olReadExternalGrouped = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) $ concatMap snd os
+    }
+
 data Option a = Option
     { optionDisplay :: Text -- ^ The user-facing label.
     , optionInternalValue :: a -- ^ The Haskell value being selected.
     , optionExternalValue :: Text -- ^ The representation of this value stored in the form.
     }
 
--- | Since 1.4.6
+-- | @since 1.4.6
 instance Functor Option where
     fmap f (Option display internal external) = Option display (f internal) external
 
@@ -637,6 +710,30 @@ optionsPairs opts = do
                  }
   return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
 
+-- | Creates an 'OptionList' from a list of (display-value, internal value) pairs.
+--
+-- @since 1.7.0
+optionsPairsGrouped
+  :: forall m msg a. (MonadHandler m, RenderMessage (HandlerSite m) msg)
+  => [(msg, [(msg, a)])] -> m (OptionList a)
+optionsPairsGrouped opts = do
+  mr <- getMessageRender
+  let mkOption (external, (display, internal)) =
+          Option { optionDisplay       = mr display
+                 , optionInternalValue = internal
+                 , optionExternalValue = pack $ show external
+                 }
+      opts' = enumerateSublists opts :: [(msg, [(Int, (msg, a))])]
+      opts'' = map (\(x, ys) -> (mr x, map mkOption ys)) opts'
+  return $ mkOptionListGrouped opts''
+
+-- | Helper to enumerate sublists with one consecutive index.
+enumerateSublists :: forall a b. [(a, [b])] -> [(a, [(Int, b)])]
+enumerateSublists xss =
+  let yss :: [(Int, (a, [b]))]
+      yss = snd $ foldl (\(i, res) xs -> (i + (length.snd) xs, res ++ [(i, xs)])) (1, []) xss
+   in map (\(i, (x, ys)) -> (x, zip [i :: Int ..] ys)) yss
+
 -- | Creates an 'OptionList' from an 'Enum', using its 'Show' instance for the user-facing value.
 optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
 optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
@@ -692,7 +789,7 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
 -- | An alternative to 'optionsPersist' which returns just the 'Key' instead of
 -- the entire 'Entity'.
 --
--- Since 1.3.2
+-- @since 1.3.2
 #if MIN_VERSION_persistent(2,5,0)
 optionsPersistKey
   :: (YesodPersist site
@@ -731,7 +828,7 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
         }) pairs
 
 -- |
--- A helper function for constucting 'selectField's. You may want to use this when you define your custom 'selectField's or 'radioField's.
+-- A helper function for constucting 'selectField's with optional option groups. You may want to use this when you define your custom 'selectField's or 'radioField's.
 --
 -- @since 1.6.2
 selectFieldHelper
@@ -739,23 +836,26 @@ selectFieldHelper
         => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()) -- ^ Outermost part of the field
         -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional
         -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options
+        -> (Maybe (Text -> WidgetFor site ())) -- ^ Group headers placed inbetween options
         -> HandlerFor site (OptionList a)
         -> Field (HandlerFor site) a
-selectFieldHelper outside onOpt inside opts' = Field
+selectFieldHelper outside onOpt inside grpHdr opts' = Field
     { fieldParse = \x _ -> do
-        opts <- opts'
+        opts <- fmap flattenOptionList opts'
         return $ selectParser opts x
     , fieldView = \theId name attrs val isReq -> do
-        opts <- fmap olOptions $ handlerToWidget opts'
         outside theId name attrs $ do
-            unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
+          optsFlat <- fmap (olOptions.flattenOptionList) $ handlerToWidget opts'
-            flip mapM_ opts $ \opt -> inside
+          unless isReq $ onOpt theId name $ render optsFlat val `notElem` map optionExternalValue optsFlat
-                theId
+          opts'' <- handlerToWidget opts'
-                name
+          case opts'' of
-                ((if isReq then (("required", "required"):) else id) attrs)
+            OptionList{} -> constructOptions theId name attrs val isReq optsFlat
-                (optionExternalValue opt)
+            OptionListGrouped{olOptionsGrouped=grps} -> do
-                ((render opts val) == optionExternalValue opt)
+                  forM_ grps $ \(grp, opts) -> do
-                (optionDisplay opt)
+                    case grpHdr of
+                      Just hdr -> hdr grp
+                      Nothing -> return ()
+                    constructOptions theId name attrs val isReq opts
     , fieldEnctype = UrlEncoded
     }
   where
@@ -768,6 +868,14 @@ selectFieldHelper outside onOpt inside opts' = Field
             x -> case olReadExternal opts x of
                     Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
                     Just y -> Right $ Just y
+    constructOptions theId name attrs val isReq opts =
+      forM_ opts $ \opt -> inside
+                           theId
+                           name
+                           ((if isReq then (("required", "required"):) else id) attrs)
+                           (optionExternalValue opt)
+                           (render opts val == optionExternalValue opt)
+                           (optionDisplay opt)
 
 -- | Creates an input with @type="file"@.
 fileField :: Monad m
@@ -864,7 +972,7 @@ prependZero t0 = if T.null t1
                            then "-0." `T.append` (T.drop 2 t1)
                            else t1
 
-  where t1 = T.dropWhile ((==) ' ') t0
+  where t1 = T.dropWhile (==' ') t0
 
 -- $optionsOverview
 -- These functions create inputs where one or more options can be selected from a list.
@@ -872,3 +980,44 @@ prependZero t0 = if T.null t1
 -- The basic datastructure used is an 'Option', which combines a user-facing display value, the internal Haskell value being selected, and an external 'Text' stored as the @value@ in the form (used to map back to the internal value). A list of these, together with a function mapping from an external value back to a Haskell value, form an 'OptionList', which several of these functions take as an argument.
 --
 -- Typically, you won't need to create an 'OptionList' directly and can instead make one with functions like 'optionsPairs' or 'optionsEnum'. Alternatively, you can use functions like 'selectFieldList', which use their @[(msg, a)]@ parameter to create an 'OptionList' themselves.
+
+-- | Creates an input with @type="color"@.
+--   The input value must be provided in hexadecimal format #rrggbb.
+--
+-- @since 1.7.1
+colorField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
+colorField = Field
+    { fieldParse = parseHelper $ \s ->
+        if isHexColor $ unpack s then Right s
+        else Left $ MsgInvalidHexColorFormat s
+    , fieldView = \theId name attrs val _ -> [whamlet|
+$newline never
+<input ##{theId} name=#{name} *{attrs} type=color value=#{either id id val}>
+|]
+    , fieldEnctype = UrlEncoded
+    }
+  where
+      isHexColor :: String -> Bool
+      isHexColor ['#',a,b,c,d,e,f] = all isHexDigit [a,b,c,d,e,f]
+      isHexColor _ = False
+
+-- | Creates an input with @type="datetime-local"@.
+--   The input value must be provided in YYYY-MM-DD(T| )HH:MM[:SS] format.
+--
+-- @since 1.7.6
+datetimeLocalField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m LocalTime
+datetimeLocalField = Field
+    { fieldParse = parseHelper $ \s -> case T.split (\c -> (c == 'T') || (c == ' ')) s of
+        [d,t] -> do
+            day <- parseDate $ unpack d
+            time <- parseTime t
+            Right $ LocalTime day time
+        _ -> Left $ MsgInvalidDatetimeFormat s
+    , fieldView = \theId name attrs val isReq -> [whamlet|
+$newline never
+<input type=datetime-local ##{theId} name=#{name} value=#{showVal val} *{attrs} :isReq:required>
+|]
+    , fieldEnctype = UrlEncoded
+    }
+  where
+    showVal = either id (pack . show)

yesod-form/Yesod/Form/I18n/Chinese.hs

@@ -24,3 +24,5 @@ chineseFormMessage (MsgInvalidBool t) = "无效的逻辑值: " `mappend` t
 chineseFormMessage MsgBoolYes = "是"
 chineseFormMessage MsgBoolNo = "否"
 chineseFormMessage MsgDelete = "删除?"
+chineseFormMessage (MsgInvalidHexColorFormat t) = "颜色无效，必须为 #rrggbb 十六进制格式: " `mappend` t
+chineseFormMessage (MsgInvalidDatetimeFormat t) = "日期時間無效，必須採用 YYYY-MM-DD(T| )HH:MM[:SS] 格式： " `mappend` t

yesod-form/Yesod/Form/I18n/Croatian.hs

@@ -24,3 +24,5 @@ croatianFormMessage (MsgInvalidBool t)    = "Logička vrijednost nije valjana: "
 croatianFormMessage MsgBoolYes            = "Da"
 croatianFormMessage MsgBoolNo             = "Ne"
 croatianFormMessage MsgDelete             = "Izbrisati?"
+croatianFormMessage (MsgInvalidHexColorFormat t) = "Nevažeća boja, mora biti u #rrggbb heksadecimalnom formatu: " `mappend` t
+croatianFormMessage (MsgInvalidDatetimeFormat t) = "Nevažeći datum i vrijeme, mora biti u formatu GGGG-MM-DD(T| )HH:MM[:SS]: " `mappend` t

yesod-form/Yesod/Form/I18n/Czech.hs

@@ -24,3 +24,5 @@ czechFormMessage (MsgInvalidBool t) = "Neplatná pravdivostní hodnota: " `mappe
 czechFormMessage MsgBoolYes = "Ano"
 czechFormMessage MsgBoolNo = "Ne"
 czechFormMessage MsgDelete = "Smazat?"
+czechFormMessage (MsgInvalidHexColorFormat t) = "Neplatná barva, musí být v #rrggbb hexadecimálním formátu: " `mappend` t
+czechFormMessage (MsgInvalidDatetimeFormat t) = "Neplatné datum a čas, musí být ve formátu YYYY-MM-DD(T| )HH:MM[:SS]: " `mappend` t

yesod-form/Yesod/Form/I18n/Dutch.hs

@@ -24,3 +24,5 @@ dutchFormMessage (MsgInvalidBool t)    = "Ongeldige waarheidswaarde: " `mappend`
 dutchFormMessage MsgBoolYes            = "Ja"
 dutchFormMessage MsgBoolNo             = "Nee"
 dutchFormMessage MsgDelete             = "Verwijderen?"
+dutchFormMessage (MsgInvalidHexColorFormat t) = "Ongeldige kleur, moet de hexadecimale indeling #rrggbb hebben: " `mappend` t
+dutchFormMessage (MsgInvalidDatetimeFormat t) = "Ongeldige datum/tijd, moet de indeling JJJJ-MM-DD(T| )UU:MM[:SS] hebben: " `mappend` t

yesod-form/Yesod/Form/I18n/English.hs

@@ -24,3 +24,5 @@ englishFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t
 englishFormMessage MsgBoolYes = "Yes"
 englishFormMessage MsgBoolNo = "No"
 englishFormMessage MsgDelete = "Delete?"
+englishFormMessage (MsgInvalidHexColorFormat t) = "Invalid color, must be in #rrggbb hexadecimal format: " `mappend` t
+englishFormMessage (MsgInvalidDatetimeFormat t) = "Invalid datetime, must be in YYYY-MM-DD(T| )HH:MM[:SS] format: " `mappend` t

yesod-form/Yesod/Form/I18n/French.hs

@@ -24,3 +24,5 @@ frenchFormMessage (MsgInvalidBool t) = "Booléen invalide : " `mappend` t
 frenchFormMessage MsgBoolYes = "Oui"
 frenchFormMessage MsgBoolNo = "Non"
 frenchFormMessage MsgDelete = "Détruire ?"
+frenchFormMessage (MsgInvalidHexColorFormat t) = "Couleur non valide. doit être au format hexadécimal #rrggbb : " `mappend` t
+frenchFormMessage (MsgInvalidDatetimeFormat t) = "Date/heure non valide. doit être au format AAAA-MM-JJ(T| )HH:MM[:SS] : " `mappend` t

yesod-form/Yesod/Form/I18n/German.hs

@@ -24,3 +24,5 @@ germanFormMessage (MsgInvalidBool t) = "Ungültiger Wahrheitswert: " `mappend` t
 germanFormMessage MsgBoolYes = "Ja"
 germanFormMessage MsgBoolNo = "Nein"
 germanFormMessage MsgDelete = "Löschen?"
+germanFormMessage (MsgInvalidHexColorFormat t) = "Ungültige Farbe, muss im Hexadezimalformat #rrggbb vorliegen: " `mappend` t
+germanFormMessage (MsgInvalidDatetimeFormat t) = "Ungültige Datums- und Uhrzeitangabe, muss im Format YYYY-MM-DD(T| )HH:MM[:SS] vorliegen: " `mappend` t

yesod-form/Yesod/Form/I18n/Japanese.hs

@@ -24,3 +24,5 @@ japaneseFormMessage (MsgInvalidBool t) = "無効なbool値です: " `mappend` t
 japaneseFormMessage MsgBoolYes = "はい"
 japaneseFormMessage MsgBoolNo = "いいえ"
 japaneseFormMessage MsgDelete = "削除しますか?"
+japaneseFormMessage (MsgInvalidHexColorFormat t) = "無効な色。＃rrggbb16進形式である必要があります: " `mappend` t
+japaneseFormMessage (MsgInvalidDatetimeFormat t) = "無効な日時です。YYYY-MM-DD(T| )HH:MM[:SS] 形式である必要があります: " `mappend` t

yesod-form/Yesod/Form/I18n/Korean.hs

@@ -24,3 +24,5 @@ koreanFormMessage (MsgInvalidBool t) = "잘못된 불(boolean)입니다: " `mapp
 koreanFormMessage MsgBoolYes = "예"
 koreanFormMessage MsgBoolNo = "아니오"
 koreanFormMessage MsgDelete = "삭제하시겠습니까?"
+koreanFormMessage (MsgInvalidHexColorFormat t) = "색상이 잘못되었습니다. #rrggbb 16진수 형식이어야 합니다.: " `mappend` t
+koreanFormMessage (MsgInvalidDatetimeFormat t) = "날짜/시간이 잘못되었습니다. YYYY-MM-DD(T| )HH:MM[:SS] 형식이어야 합니다.: " `mappend` t

yesod-form/Yesod/Form/I18n/Norwegian.hs

@@ -24,3 +24,5 @@ norwegianBokmålFormMessage MsgBoolYes = "Ja"
 norwegianBokmålFormMessage MsgBoolNo = "Nei"
 norwegianBokmålFormMessage MsgDelete = "Slette?"
 norwegianBokmålFormMessage MsgCsrfWarning = "Som beskyttelse mot «cross-site request forgery»-angrep, vennligst bekreft innsendt skjema."
+norwegianBokmålFormMessage (MsgInvalidHexColorFormat t) = "Ugyldig farge, må være i #rrggbb heksadesimalt format: " `mappend` t
+norwegianBokmålFormMessage (MsgInvalidDatetimeFormat t) = "Ugyldig datoklokkeslett, må være i formatet ÅÅÅÅ-MM-DD(T| )HH:MM[:SS]:" `mappend` t

yesod-form/Yesod/Form/I18n/Portuguese.hs

@@ -24,3 +24,5 @@ portugueseFormMessage (MsgInvalidBool t) = "Booleano inválido: " `mappend` t
 portugueseFormMessage MsgBoolYes = "Sim"
 portugueseFormMessage MsgBoolNo = "Não"
 portugueseFormMessage MsgDelete = "Remover?"
+portugueseFormMessage (MsgInvalidHexColorFormat t) = "Cor inválida, deve estar no formato #rrggbb hexadecimal: " `mappend` t
+portugueseFormMessage (MsgInvalidDatetimeFormat t) = "Data e hora inválida, deve estar no formato AAAA-MM-DD(T| )HH:MM[:SS]: " `mappend` t

yesod-form/Yesod/Form/I18n/Romanian.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Form.I18n.Romanian where
+
+import Yesod.Form.Types (FormMessage (..))
+import Data.Monoid (mappend)
+import Data.Text (Text)
+
+-- | Romanian translation
+--
+-- @since 1.7.5
+romanianFormMessage :: FormMessage -> Text
+romanianFormMessage (MsgInvalidInteger t) = "Număr întreg nevalid: " `Data.Monoid.mappend` t
+romanianFormMessage (MsgInvalidNumber t) = "Număr nevalid: " `mappend` t
+romanianFormMessage (MsgInvalidEntry t) = "Valoare nevalidă: " `mappend` t
+romanianFormMessage MsgInvalidTimeFormat = "Oră nevalidă. Formatul necesar este HH:MM[:SS]"
+romanianFormMessage MsgInvalidDay = "Dată nevalidă. Formatul necesar este AAAA-LL-ZZ"
+romanianFormMessage (MsgInvalidUrl t) = "Adresă URL nevalidă: " `mappend` t
+romanianFormMessage (MsgInvalidEmail t) = "Adresă de e-mail nevalidă: " `mappend` t
+romanianFormMessage (MsgInvalidHour t) = "Oră nevalidă: " `mappend` t
+romanianFormMessage (MsgInvalidMinute t) = "Minut nevalid: " `mappend` t
+romanianFormMessage (MsgInvalidSecond t) = "Secundă nevalidă: " `mappend` t
+romanianFormMessage MsgCsrfWarning = "Ca protecție împotriva atacurilor CSRF, vă rugăm să confirmați trimiterea formularului."
+romanianFormMessage MsgValueRequired = "Câmp obligatoriu"
+romanianFormMessage (MsgInputNotFound t) = "Valoare inexistentă: " `mappend` t
+romanianFormMessage MsgSelectNone = "<Niciuna>"
+romanianFormMessage (MsgInvalidBool t) = "Valoare booleană nevalidă: " `mappend` t
+romanianFormMessage MsgBoolYes = "Da"
+romanianFormMessage MsgBoolNo = "Nu"
+romanianFormMessage MsgDelete = "Șterge?"
+romanianFormMessage (MsgInvalidHexColorFormat t) = "Culoare nevalidă. Formatul necesar este #rrggbb în hexazecimal: " `mappend` t
+romanianFormMessage (MsgInvalidDatetimeFormat t) = "Data și ora nevalidă, trebuie să fie în format AAAA-LL-ZZ(T| )HH:MM[:SS]: " `mappend` t

yesod-form/Yesod/Form/I18n/Russian.hs

@@ -24,3 +24,5 @@ russianFormMessage (MsgInvalidBool t) = "Неверное логическое
 russianFormMessage MsgBoolYes = "Да"
 russianFormMessage MsgBoolNo = "Нет"
 russianFormMessage MsgDelete = "Удалить?"
+russianFormMessage (MsgInvalidHexColorFormat t) = "Недопустимое значение цвета, должен быть в шестнадцатеричном формате #rrggbb: " `mappend` t
+russianFormMessage (MsgInvalidDatetimeFormat t) = "Недопустимое значение даты и времени. Должно быть в формате ГГГГ-ММ-ДД(T| )ЧЧ:ММ[:СС]: " `mappend` t

yesod-form/Yesod/Form/I18n/Spanish.hs

@@ -25,3 +25,5 @@ spanishFormMessage (MsgInvalidBool t) = "Booleano inválido: " `mappend` t
 spanishFormMessage MsgBoolYes = "Sí"
 spanishFormMessage MsgBoolNo = "No"
 spanishFormMessage MsgDelete = "¿Eliminar?"
+spanishFormMessage (MsgInvalidHexColorFormat t) = "Color no válido, debe estar en formato hexadecimal #rrggbb: " `mappend` t
+spanishFormMessage (MsgInvalidDatetimeFormat t) = "Fecha y hora no válida; debe estar en formato AAAA-MM-DD(T| )HH:MM[:SS]: " `mappend` t

yesod-form/Yesod/Form/I18n/Swedish.hs

@@ -24,3 +24,5 @@ swedishFormMessage MsgBoolYes = "Ja"
 swedishFormMessage MsgBoolNo = "Nej"
 swedishFormMessage MsgDelete = "Radera?"
 swedishFormMessage MsgCsrfWarning = "Som skydd mot \"cross-site request forgery\" attacker, vänligen bekräfta skickandet av formuläret."
+swedishFormMessage (MsgInvalidHexColorFormat t) = "Ogiltig färg, måste vara i #rrggbb hexadecimalt format: " `mappend` t
+swedishFormMessage (MsgInvalidDatetimeFormat t) = "Ogiltig datumtid, måste vara i formatet ÅÅÅÅ-MM-DD(T| )TT:MM[:SS]: " `mappend` t

yesod-form/Yesod/Form/Types.hs

@@ -166,6 +166,18 @@ instance Monad m => Applicative (AForm m) where
         (a, b, ints', c) <- f mr env ints
         (x, y, ints'', z) <- g mr env ints'
         return (a <*> x, b . y, ints'', c `mappend` z)
+
+#if MIN_VERSION_transformers(0,6,0)
+instance Monad m => Monad (AForm m) where
+    (AForm f) >>= k = AForm $ \mr env ints -> do
+        (a, b, ints', c) <- f mr env ints
+        case a of
+          FormSuccess r -> do 
+            (x, y, ints'', z) <- unAForm (k r) mr env ints'
+            return (x, b . y, ints'', c `mappend` z)
+          FormFailure err -> pure (FormFailure err, b, ints', c)
+          FormMissing -> pure (FormMissing, b, ints', c)
+#endif
 instance (Monad m, Monoid a) => Monoid (AForm m a) where
     mempty = pure mempty
     mappend a b = mappend <$> a <*> b
@@ -229,4 +241,6 @@ data FormMessage = MsgInvalidInteger Text
                  | MsgBoolYes
                  | MsgBoolNo
                  | MsgDelete
+                 | MsgInvalidHexColorFormat Text
+                 | MsgInvalidDatetimeFormat Text
     deriving (Show, Eq, Read)

yesod-form/yesod-form.cabal

@@ -1,5 +1,6 @@
+cabal-version:   >= 1.10
 name:            yesod-form
-version:         1.6.7
+version:         1.7.6
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -7,10 +8,9 @@ maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        Form handling support for Yesod Web Framework
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
-description:     API docs and the README are available at <http://www.stackage.org/package/yesod-form>.  Third-party packages which you can find useful: <http://hackage.haskell.org/package/yesod-form-richtext yesod-form-richtext> - richtext form fields (currntly it provides only Summernote support).
+description:     API docs and the README are available at <http://www.stackage.org/package/yesod-form>.  Third-party packages which you can find useful: <http://hackage.haskell.org/package/yesod-form-richtext yesod-form-richtext> - richtext form fields (currently it provides only Summernote support).
 extra-source-files: ChangeLog.md
                     README.md
 
@@ -19,6 +19,7 @@ flag network-uri
   default: True
 
 library
+    default-language: Haskell2010
     build-depends:   base                  >= 4.10     && < 5
                    , aeson
                    , attoparsec            >= 0.10
@@ -32,7 +33,6 @@ library
                    , email-validate        >= 1.0
                    , persistent
                    , resourcet
-                   , semigroups
                    , shakespeare           >= 2.0
                    , text                  >= 0.9
                    , time                  >= 1.1.4
@@ -67,10 +67,12 @@ library
                      Yesod.Form.I18n.Spanish
                      Yesod.Form.I18n.Chinese
                      Yesod.Form.I18n.Korean
+                     Yesod.Form.I18n.Romanian
                      -- FIXME Yesod.Helpers.Crud
     ghc-options:     -Wall
 
 test-suite test
+    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: main.hs
     hs-source-dirs: test

yesod-persistent/ChangeLog.md

@@ -1,5 +1,21 @@
 # ChangeLog for yesod-persistent
 
+## 1.6.0.8
+
+* Add support for `persistent-2.14` [#1706](https://github.com/yesodweb/yesod/pull/1760)
+
+## 1.6.0.7
+
+* Add support for persistent 2.13. [#1723](https://github.com/yesodweb/yesod/pull/1723)
+
+## 1.6.0.6
+
+* Add support for persistent 2.12
+
+## 1.6.0.5
+
+* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)
+
 ## 1.6.0.4
 
 * Fix test suite to be compatible with latest `persistent-template`

yesod-persistent/Yesod/Persist/Core.hs

@@ -25,6 +25,7 @@ module Yesod.Persist.Core
 import Database.Persist
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 
+import Data.Foldable (toList)
 import Yesod.Core
 import Data.Conduit
 import Blaze.ByteString.Builder (Builder)
@@ -33,6 +34,12 @@ import Control.Monad.Trans.Resource
 import Control.Exception (throwIO)
 import Yesod.Core.Types (HandlerContents (HCError))
 import qualified Database.Persist.Sql as SQL
+#if MIN_VERSION_persistent(2,13,0)
+import qualified Database.Persist.SqlBackend.Internal as SQL
+#endif
+#if MIN_VERSION_persistent(2,14,0)
+import Database.Persist.Class.PersistEntity
+#endif
 
 unSqlPersistT :: a -> a
 unSqlPersistT = id
@@ -183,26 +190,46 @@ getBy404 key = do
 -- is violated.
 --
 -- @since 1.4.1
-#if MIN_VERSION_persistent(2,5,0)
+#if MIN_VERSION_persistent(2,14,0)
-insert400 :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend)
+insert400
-          => val
+    :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend, SafeToInsert val)
-          -> ReaderT backend m (Key val)
+    => val
+    -> ReaderT backend m (Key val)
+#elif MIN_VERSION_persistent(2,5,0)
+insert400
+    :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend)
+    => val
+    -> ReaderT backend m (Key val)
 #else
-insert400 :: (MonadIO m, PersistUnique (PersistEntityBackend val), PersistEntity val)
+insert400
-          => val
+    :: (MonadIO m, PersistUnique (PersistEntityBackend val), PersistEntity val)
-          -> ReaderT (PersistEntityBackend val) m (Key val)
+    => val
+    -> ReaderT (PersistEntityBackend val) m (Key val)
 #endif
 insert400 datum = do
     conflict <- checkUnique datum
     case conflict of
         Just unique ->
+#if MIN_VERSION_persistent(2, 12, 0)
+-- toList is called here because persistent-2.13 changed this
+-- to a nonempty list. for versions of persistent prior to 2.13, toList
+-- will be a no-op. for persistent-2.13, it'll convert the NonEmptyList to
+-- a List.
+            badRequest' $ map (unFieldNameHS . fst) $ toList $ persistUniqueToFieldNames unique
+#else
             badRequest' $ map (unHaskellName . fst) $ persistUniqueToFieldNames unique
+#endif
         Nothing -> insert datum
 
 -- | Same as 'insert400', but doesn’t return a key.
 --
 -- @since 1.4.1
-#if MIN_VERSION_persistent(2,5,0)
+#if MIN_VERSION_persistent(2,14,0)
+insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend, SafeToInsert val)
+           => val
+           -> ReaderT backend m ()
+
+#elif MIN_VERSION_persistent(2,5,0)
 insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend)
            => val
            -> ReaderT backend m ()

yesod-persistent/test/Yesod/PersistSpec.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies #-}
 {-# LANGUAGE EmptyDataDecls, FlexibleContexts, GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}

yesod-persistent/yesod-persistent.cabal

@@ -1,5 +1,6 @@
+cabal-version:   >= 1.10
 name:            yesod-persistent
-version:         1.6.0.4
+version:         1.6.0.8
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -7,17 +8,17 @@ maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        Some helpers for using Persistent from Yesod.
 category:        Web, Yesod, Database
 stability:       Stable
-cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-persistent>
 extra-source-files: README.md ChangeLog.md
 
 library
+    default-language: Haskell2010
     build-depends:   base                      >= 4.10     && < 5
                    , yesod-core                >= 1.6      && < 1.7
-                   , persistent                >= 2.8      && < 2.11
+                   , persistent                >= 2.8
-                   , persistent-template       >= 2.1      && < 2.9
+                   , persistent-template       >= 2.1
                    , transformers              >= 0.2.2
                    , blaze-builder
                    , conduit
@@ -28,10 +29,12 @@ library
     ghc-options:     -Wall
 
 test-suite test
+    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: Spec.hs
     hs-source-dirs: test
     other-modules: Yesod.PersistSpec
+    build-tool-depends: hspec-discover:hspec-discover
     build-depends: base
                  , hspec
                  , wai-extra

yesod-static/ChangeLog.md

@@ -1,3 +1,9 @@
+# ChangeLog for yesod-static
+
+## 1.6.1.0
+
+* Support reproducible embedded file order [#1684](https://github.com/yesodweb/yesod/issues/1684#issuecomment-652562514)
+
 ## 1.6.0.2
 
 * Remove unnecessary deriving of Typeable

yesod-static/Yesod/EmbeddedStatic/Generators.hs

@@ -49,6 +49,7 @@ import qualified System.Process as Proc
 import System.Exit (ExitCode (ExitSuccess))
 import Control.Concurrent.Async (Concurrently (..))
 import System.IO (hClose)
+import Data.List (sort)
 
 import Yesod.EmbeddedStatic.Types
 
@@ -80,7 +81,7 @@ getRecursiveContents :: Location -- ^ The directory to search
                      -> FilePath   -- ^ The prefix to add to the filenames
                      -> IO [(Location,FilePath)]
 getRecursiveContents prefix topdir = do
-  names <- getDirectoryContents topdir
+  names <- sort <$> getDirectoryContents topdir
   let properNames = filter (`notElem` [".", ".."]) names
   paths <- forM properNames $ \name -> do
     let path = topdir </> name

yesod-static/Yesod/Static.hs

@@ -71,7 +71,7 @@ import Data.FileEmbed (embedDir)
 import Yesod.Core
 import Yesod.Core.Types
 
-import Data.List (intercalate)
+import Data.List (intercalate, sort)
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax as TH
 
@@ -192,7 +192,7 @@ getFileListPieces = flip evalStateT M.empty . flip go id
        -> ([String] -> [String])
        -> StateT (M.Map String String) IO [[String]]
     go fp front = do
-        allContents <- liftIO $ filter notHidden `fmap` getDirectoryContents fp
+        allContents <- liftIO $ (sort . filter notHidden) `fmap` getDirectoryContents fp
         let fullPath :: String -> String
             fullPath f = fp ++ '/' : f
         files <- liftIO $ filterM (doesFileExist . fullPath) allContents

yesod-static/yesod-static.cabal

@@ -1,5 +1,5 @@
 name:            yesod-static
-version:         1.6.0.2
+version:         1.6.1.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -7,7 +7,7 @@ maintainer:      Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweb
 synopsis:        Static file serving subsite for Yesod Web Framework.
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.8
+cabal-version:   >= 1.10
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-static>
@@ -26,6 +26,7 @@ extra-source-files:
   README.md
 
 library
+    default-language: Haskell2010
     build-depends:   base                  >= 4.10     && < 5
                    , async
                    , attoparsec            >= 0.10
@@ -66,9 +67,10 @@ library
                      Yesod.EmbeddedStatic.Css.Util
 
     ghc-options:     -Wall
-    extensions: TemplateHaskell
+    other-extensions: TemplateHaskell
 
 test-suite tests
+    default-language: Haskell2010
     hs-source-dirs: ., test
     main-is: tests.hs
     type: exitcode-stdio-1.0
@@ -118,7 +120,7 @@ test-suite tests
                    , rio
 
     ghc-options:     -Wall -threaded
-    extensions: TemplateHaskell
+    other-extensions: TemplateHaskell
 
 source-repository head
   type:     git

yesod-test/ChangeLog.md

@@ -1,8 +1,42 @@
 # ChangeLog for yesod-test
 
+
+## 1.6.16
+
+* Add `addBareGetParam` to yesod-test. [#1821](https://github.com/yesodweb/yesod/pull/1821)
+
+## 1.6.15
+
+* Add `bySelectorLabelContain`. [#1781](https://github.com/yesodweb/yesod/pull/1781)
+
+## 1.6.14
+
+* Fix quotes not matching in htmlContain* functions [#1768](https://github.com/yesodweb/yesod/pull/1768).
+* Add logging of the matches found of these functions [#1768](https://github.com/yesodweb/yesod/pull/1768).
+* Improved failure messages from `assertEq`. [#1767](https://github.com/yesodweb/yesod/pull/1767)
+
+## 1.6.13
+
+* Add `Yesod.Test.Internal.SIO` module to expose the `SIO` type.
+
+## 1.6.12
+
+* Fix import in cookie example [#1713](https://github.com/yesodweb/yesod/pull/1713)
+* Add `MonadState` instance for `SIO`
+
+## 1.6.11
+
+* Add missing `HasCallStack`s [#1710](https://github.com/yesodweb/yesod/pull/1710)
+
+## 1.6.10
+
+* `statusIs` assertion failures now print a preview of the response body, if the response body is UTF-8 or ASCII. [#1680](https://github.com/yesodweb/yesod/pull/1680/files)
+* Adds an `Yesod.Test.Internal`, which exposes functions that yesod-test uses. These functions do _not_ constitute a stable API.
+
 ## 1.6.9.1
 
 * Improve documentation [#1676](https://github.com/yesodweb/yesod/pull/1676)
+* Require GHC 8.2 (base >= 4.10)
 
 ## 1.6.9
 

yesod-test/README.md

@@ -42,9 +42,9 @@ spec = withApp $ do
           addToken -- Add the CSRF _token field with the currently shown value.
 
           -- Lookup field by the text on the labels pointing to them.
-          byLabel "Email:" "gustavo@cerati.com"
+          byLabelExact "Email:" "gustavo@cerati.com"
-          byLabel "Password:" "secret"
+          byLabelExact "Password:" "secret"
-          byLabel "Confirm:" "secret"
+          byLabelExact "Confirm:" "secret"
 
       it "Sends another form, this one has a file" $ do
         request $ do

yesod-test/Yesod/Test.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 {-|
 Yesod.Test is a pragmatic framework for testing web applications built
@@ -151,6 +152,7 @@ module Yesod.Test
     , setMethod
     , addPostParam
     , addGetParam
+    , addBareGetParam
     , addFile
     , setRequestBody
     , RequestBuilder
@@ -169,6 +171,7 @@ module Yesod.Test
     , byLabelContain
     , byLabelPrefix
     , byLabelSuffix
+    , bySelectorLabelContain
     , fileByLabel
     , fileByLabelExact
     , fileByLabelContain
@@ -240,23 +243,21 @@ import qualified Network.Socket.Internal as Sock
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
+import qualified Text.Blaze.Renderer.String as Blaze
+import qualified Text.Blaze as Blaze
 import Network.Wai
 import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
-import Control.Monad.Trans.Reader (ReaderT (..))
-import Conduit (MonadThrow)
 import Control.Monad.IO.Class
 import System.IO
 import Yesod.Core.Unsafe (runFakeHandler)
 import Yesod.Test.TransversingCSS
 import Yesod.Core
-import Yesod.Core.Json (contentTypeHeaderIsJson)
 import qualified Data.Text.Lazy as TL
 import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With)
 import Text.XML.Cursor hiding (element)
 import qualified Text.XML.Cursor as C
 import qualified Text.HTML.DOM as HD
 import Control.Monad.Trans.Writer
-import Data.IORef
 import qualified Data.Map as M
 import qualified Web.Cookie as Cookie
 import qualified Blaze.ByteString.Builder as Builder
@@ -279,6 +280,9 @@ import Network.HTTP.Types.Header (hContentType)
 import Data.Aeson (FromJSON, eitherDecode')
 import Control.Monad (unless)
 
+import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8)
+import Yesod.Test.Internal.SIO
+
 {-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-}
 {-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-}
 
@@ -461,7 +465,7 @@ testModifySite newSiteFn = do
 --
 -- ==== __Examples__
 --
--- > import qualified Data.Cookie as Cookie
+-- > import qualified Web.Cookie as Cookie
 -- > :set -XOverloadedStrings
 -- > testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "name" }
 --
@@ -499,7 +503,8 @@ testClearCookies = do
 
 -- Performs a given action using the last response. Use this to create
 -- response-level assertions
-withResponse' :: (state -> Maybe SResponse)
+withResponse' :: HasCallStack
+              => (state -> Maybe SResponse)
               -> [T.Text]
               -> (SResponse -> SIO state a)
               -> SIO state a
@@ -513,7 +518,7 @@ withResponse' getter errTrace f = maybe err f . getter =<< getSIO
 
 -- | Performs a given action using the last response. Use this to create
 -- response-level assertions
-withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a
+withResponse :: HasCallStack => (SResponse -> YesodExample site a) -> YesodExample site a
 withResponse = withResponse' yedResponse []
 
 -- | Use HXT to parse a value from an HTML tag.
@@ -522,7 +527,8 @@ parseHTML :: HtmlLBS -> Cursor
 parseHTML html = fromDocument $ HD.parseLBS html
 
 -- | Query the last response using CSS selectors, returns a list of matched fragments
-htmlQuery' :: (state -> Maybe SResponse)
+htmlQuery' :: HasCallStack
+           => (state -> Maybe SResponse)
            -> [T.Text]
            -> Query
            -> SIO state [HtmlLBS]
@@ -532,7 +538,7 @@ htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQu
     Right matches -> return $ map (encodeUtf8 . TL.pack) matches
 
 -- | Query the last response using CSS selectors, returns a list of matched fragments
-htmlQuery :: Query -> YesodExample site [HtmlLBS]
+htmlQuery :: HasCallStack => Query -> YesodExample site [HtmlLBS]
 htmlQuery = htmlQuery' yedResponse []
 
 -- | Asserts that the two given values are equal.
@@ -542,10 +548,8 @@ htmlQuery = htmlQuery' yedResponse []
 -- @since 1.5.2
 assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
 assertEq m a b =
-  liftIO $ HUnit.assertBool msg (a == b)
+  liftIO $ HUnit.assertEqual msg a b
-  where msg = "Assertion: " ++ m ++ "\n" ++
+  where msg = "Assertion: " ++ m ++ "\n"
-              "First argument:  " ++ ppShow a ++ "\n" ++
-              "Second argument: " ++ ppShow b ++ "\n"
 
 -- | Asserts that the two given values are not equal.
 --
@@ -569,17 +573,25 @@ assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample si
 assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b)
 
 -- | Assert the last response status is as expected.
+-- If the status code doesn't match, a portion of the body is also printed to aid in debugging.
 --
 -- ==== __Examples__
 --
 -- > get HomeR
 -- > statusIs 200
 statusIs :: HasCallStack => Int -> YesodExample site ()
-statusIs number = withResponse $ \ SResponse { simpleStatus = s } ->
+statusIs number = do
-  liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat
+  withResponse $ \(SResponse status headers body) -> do
-    [ "Expected status was ", show number
+    let mContentType = lookup hContentType headers
-    , " but received status was ", show $ H.statusCode s
+        isUTF8ContentType = maybe False contentTypeHeaderIsUtf8 mContentType
-    ]
+
+    liftIO $ flip HUnit.assertBool (H.statusCode status == number) $ concat
+      [ "Expected status was ", show number
+      , " but received status was ", show $ H.statusCode status
+      , if isUTF8ContentType
+          then ". For debugging, the body was: " <> (T.unpack $ getBodyTextPreview body)
+          else ""
+      ]
 
 -- | Assert the given header key/value pair was returned.
 --
@@ -698,8 +710,13 @@ htmlAllContain query search = do
   matches <- htmlQuery query
   case matches of
     [] -> failure $ "Nothing matched css query: " <> query
-    _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $
+    _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search  ++ " matches: " ++ show matches) $
-          DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
+          DL.all (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
+
+-- | puts the search trough the same escaping as the matches are.
+--   this helps with matching on special characters
+escape :: String -> String
+escape = Blaze.renderMarkup . Blaze.string
 
 -- | Queries the HTML using a CSS selector, and passes if any matched
 -- element contains the given string.
@@ -716,8 +733,8 @@ htmlAnyContain query search = do
   matches <- htmlQuery query
   case matches of
     [] -> failure $ "Nothing matched css query: " <> query
-    _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search) $
+    _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search ++ " matches: " ++ show matches) $
-          DL.any (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
+          DL.any (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
 
 -- | Queries the HTML using a CSS selector, and fails if any matched
 -- element contains the given string (in other words, it is the logical
@@ -733,7 +750,7 @@ htmlAnyContain query search = do
 htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site ()
 htmlNoneContain query search = do
   matches <- htmlQuery query
-  case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of
+  case DL.filter (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches) of
     [] -> return ()
     found -> failure $ "Found " <> T.pack (show $ length found) <>
                 " instances of " <> T.pack search <> " in " <> query <> " elements"
@@ -774,13 +791,7 @@ requireJSONResponse = do
         isJSONContentType
         (failure $ T.pack $ "Expected `Content-Type: application/json` in the headers, got: " ++ show headers)
     case eitherDecode' body of
-        Left err -> do
+        Left err -> failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err, "JSON: ", getBodyTextPreview body]
-          let characterLimit = 1024
-              textBody = TL.toStrict $ decodeUtf8 body
-              bodyPreview = if T.length textBody < characterLimit
-                then textBody
-                else T.take characterLimit textBody <> "... (use `printBody` to see complete response body)"
-          failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err, "JSON: ", bodyPreview]
         Right v -> return v
 
 -- | Outputs the last response body to stderr (So it doesn't get captured by HSpec). Useful for debugging.
@@ -800,7 +811,7 @@ printBody = withResponse $ \ SResponse { simpleBody = b } ->
 -- > {-# LANGUAGE OverloadedStrings #-}
 -- > get HomeR
 -- > printMatches "h1" -- Prints all h1 tags
-printMatches :: Query -> YesodExample site ()
+printMatches :: HasCallStack => Query -> YesodExample site ()
 printMatches query = do
   matches <- htmlQuery query
   liftIO $ hPutStrLn stderr $ show matches
@@ -839,6 +850,23 @@ addGetParam name value = modifySIO $ \rbd -> rbd
               : rbdGets rbd
     }
 
+-- | Add a bare parameter with the given name and no value to the query
+-- string. The parameter is added without an @=@ sign.
+--
+-- You can specify the entire query string literally by adding a single bare
+-- parameter and no other parameters.
+--
+-- @since 1.6.16
+-- 
+-- ==== __Examples__
+--
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- > request $ do
+-- >   addBareGetParam "key" -- Adds ?key to the URL
+addBareGetParam :: T.Text -> RequestBuilder site ()
+addBareGetParam name = modifySIO $ \rbd ->
+    rbd {rbdGets = (TE.encodeUtf8 name, Nothing) : rbdGets rbd}
+
 -- | Add a file to be posted with the current request.
 --
 -- Adding a file will automatically change your request content-type to be multipart/form-data.
@@ -860,16 +888,43 @@ addFile name path mimetype = do
 
 -- |
 -- This looks up the name of a field based on the contents of the label pointing to it.
-genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
+genericNameFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
 genericNameFromLabel match label = do
   mres <- fmap rbdResponse getSIO
   res <-
     case mres of
       Nothing -> failure "genericNameFromLabel: No response available"
       Just res -> return res
+  let body = simpleBody res
+  case genericNameFromHTML match label body of
+    Left e -> failure e
+    Right x -> pure x
+
+-- |
+-- This looks up the name of a field based on a CSS selector and the contents of the label pointing to it.
+genericNameFromSelectorLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> T.Text -> RequestBuilder site T.Text
+genericNameFromSelectorLabel match selector label = do
+  mres <- fmap rbdResponse getSIO
+  res <-
+    case mres of
+      Nothing -> failure "genericNameSelectorFromLabel: No response available"
+      Just res -> return res
+  let body = simpleBody res
+  html <-
+    case findBySelector body selector of
+        Left parseError -> failure $ "genericNameFromSelectorLabel: Parse error" <> T.pack parseError
+        Right [] -> failure $ "genericNameFromSelectorLabel: No fragments match selector " <> selector
+        Right [matchingFragment] -> pure $ BSL8.pack matchingFragment
+        Right _matchingFragments -> failure $ "genericNameFromSelectorLabel: Multiple fragments match selector " <> selector
+  case genericNameFromHTML match label html of
+    Left e -> failure e
+    Right x -> pure x
+
+genericNameFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text
+genericNameFromHTML match label html =
   let
-    body = simpleBody res
+    parsedHTML = parseHTML html
-    mlabel = parseHTML body
+    mlabel = parsedHTML
                 $// C.element "label"
                 >=> isContentMatch label
     mfor = mlabel >>= attribute "for"
@@ -878,26 +933,26 @@ genericNameFromLabel match label = do
         | x `match` T.concat (c $// content) = [c]
         | otherwise = []
 
-  case mfor of
+  in case mfor of
     for:[] -> do
-      let mname = parseHTML body
+      let mname = parsedHTML
                     $// attributeIs "id" for
                     >=> attribute "name"
       case mname of
-        "":_ -> failure $ T.concat
+        "":_ -> Left $ T.concat
             [ "Label "
             , label
             , " resolved to id "
             , for
             , " which was not found. "
             ]
-        name:_ -> return name
+        name:_ -> Right name
-        [] -> failure $ "No input with id " <> for
+        [] -> Left $ "No input with id " <> for
     [] ->
       case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of
-        [] -> failure $ "No label contained: " <> label
+        [] -> Left $ "No label contained: " <> label
-        name:_ -> return name
+        name:_ -> Right name
-    _ -> failure $ "More than one label contained " <> label
+    _ -> Left $ "More than one label contained " <> label
 
 byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
                  -> T.Text                     -- ^ The text contained in the @\<label>@.
@@ -907,6 +962,15 @@ byLabelWithMatch match label value = do
   name <- genericNameFromLabel match label
   addPostParam name value
 
+bySelectorLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
+                 -> T.Text                     -- ^ The CSS selector.
+                 -> T.Text                     -- ^ The text contained in the @\<label>@.
+                 -> T.Text                     -- ^ The value to set the parameter to.
+                 -> RequestBuilder site ()
+bySelectorLabelWithMatch match selector label value = do
+  name <- genericNameFromSelectorLabel match selector label
+  addPostParam name value
+
 -- How does this work for the alternate <label><input></label> syntax?
 
 -- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter
@@ -1020,6 +1084,18 @@ byLabelSuffix :: T.Text -- ^ The text in the @\<label>@.
               -> RequestBuilder site ()
 byLabelSuffix = byLabelWithMatch T.isSuffixOf
 
+-- |
+-- Note: This function throws an error if it finds multiple labels or if the
+-- CSS selector fails to parse, doesn't match any fragment, or matches multiple
+-- fragments.
+--
+-- @since 1.6.15
+bySelectorLabelContain :: T.Text -- ^ The CSS selector.
+               -> T.Text -- ^ The text in the @\<label>@.
+               -> T.Text -- ^ The value to set the parameter to.
+               -> RequestBuilder site ()
+bySelectorLabelContain = bySelectorLabelWithMatch T.isInfixOf
+
 fileByLabelWithMatch  :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
                       -> T.Text                     -- ^ The text contained in the @\<label>@.
                       -> FilePath                   -- ^ The path to the file.
@@ -1132,7 +1208,7 @@ fileByLabelSuffix = fileByLabelWithMatch T.isSuffixOf
 --
 -- > request $ do
 -- >   addToken_ "#formID"
-addToken_ :: Query -> RequestBuilder site ()
+addToken_ :: HasCallStack => Query -> RequestBuilder site ()
 addToken_ scope = do
   matches <- htmlQuery' rbdResponse ["Tried to get CSRF token with addToken'"] $ scope <> " input[name=_token][type=hidden][value]"
   case matches of
@@ -1146,7 +1222,7 @@ addToken_ scope = do
 --
 -- > request $ do
 -- >   addToken
-addToken :: RequestBuilder site ()
+addToken :: HasCallStack => RequestBuilder site ()
 addToken = addToken_ ""
 
 -- | Calls 'addTokenFromCookieNamedToHeaderNamed' with the 'defaultCsrfCookieName' and 'defaultCsrfHeaderName'.
@@ -1159,7 +1235,7 @@ addToken = addToken_ ""
 -- >   addTokenFromCookie
 --
 -- Since 1.4.3.2
-addTokenFromCookie :: RequestBuilder site ()
+addTokenFromCookie :: HasCallStack => RequestBuilder site ()
 addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName defaultCsrfHeaderName
 
 -- | Looks up the CSRF token stored in the cookie with the given name and adds it to the request headers. An error is thrown if the cookie can't be found.
@@ -1175,7 +1251,8 @@ addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName
 -- >   addTokenFromCookieNamedToHeaderNamed "cookieName" (CI "headerName")
 --
 -- Since 1.4.3.2
-addTokenFromCookieNamedToHeaderNamed :: ByteString -- ^ The name of the cookie
+addTokenFromCookieNamedToHeaderNamed :: HasCallStack
+                                     => ByteString -- ^ The name of the cookie
                                      -> CI ByteString -- ^ The name of the header
                                      -> RequestBuilder site ()
 addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
@@ -1198,7 +1275,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
 -- >   liftIO $ putStrLn $ "Cookies are: " ++ show cookies
 --
 -- Since 1.4.3.2
-getRequestCookies :: RequestBuilder site Cookies
+getRequestCookies :: HasCallStack => RequestBuilder site Cookies
 getRequestCookies = do
   requestBuilderData <- getSIO
   headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
@@ -1360,7 +1437,7 @@ setUrl url' = do
 -- > clickOn "a#idofthelink"
 --
 -- @since 1.5.7
-clickOn :: Yesod site => Query -> YesodExample site ()
+clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site ()
 clickOn query = do
   withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res ->
     case findAttributeBySelector (simpleBody res) query "href" of
@@ -1564,7 +1641,7 @@ parseSetCookies :: [H.Header] -> [Cookie.SetCookie]
 parseSetCookies headers = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ headers
 
 -- Yes, just a shortcut
-failure :: (MonadIO a) => T.Text -> a b
+failure :: (HasCallStack, MonadIO a) => T.Text -> a b
 failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error ""
 
 type TestApp site = (site, Middleware)
@@ -1588,27 +1665,3 @@ instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) whe
                 return ())
             params
             ($ ())
-
--- | State + IO
---
--- @since 1.6.0
-newtype SIO s a = SIO (ReaderT (IORef s) IO a)
-  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
-
-getSIO :: SIO s s
-getSIO = SIO $ ReaderT readIORef
-
-putSIO :: s -> SIO s ()
-putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
-
-modifySIO :: (s -> s) -> SIO s ()
-modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
-
-evalSIO :: SIO s a -> s -> IO a
-evalSIO (SIO (ReaderT f)) s = newIORef s >>= f
-
-execSIO :: SIO s () -> s -> IO s
-execSIO (SIO (ReaderT f)) s = do
-  ref <- newIORef s
-  f ref
-  readIORef ref

yesod-test/Yesod/Test/Internal.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module exposes functions that are used internally by yesod-test.
+-- The functions exposed here are _not_ a stable API—they may be changed or removed without any major version bump.
+--
+-- That said, you may find them useful if your application can accept API breakage.
+module Yesod.Test.Internal
+  ( getBodyTextPreview
+  , contentTypeHeaderIsUtf8
+  , assumedUTF8ContentTypes
+  ) where
+
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as DTLE
+import qualified Yesod.Core.Content as Content
+import Data.Semigroup (Semigroup(..))
+
+-- | Helper function to get the first 1024 characters of the body, assuming it is UTF-8.
+-- This function is used to preview the body in case of an assertion failure.
+--
+-- @since 1.6.10
+getBodyTextPreview :: LBS.ByteString -> T.Text
+getBodyTextPreview body =
+  let characterLimit = 1024
+      textBody = TL.toStrict $ DTLE.decodeUtf8 body
+  in if T.length textBody < characterLimit
+        then textBody
+        else T.take characterLimit textBody <> "... (use `printBody` to see complete response body)"
+
+-- | Helper function to determine if we can print a body as plain text, for debugging purposes.
+--
+-- @since 1.6.10
+contentTypeHeaderIsUtf8 :: BS8.ByteString -> Bool
+contentTypeHeaderIsUtf8 contentTypeBS =
+      -- Convert to Text, so we can use T.splitOn
+  let contentTypeText = T.toLower $ TE.decodeUtf8 contentTypeBS
+      isUTF8FromCharset = case T.splitOn "charset=" contentTypeText of
+        -- Either a specific designation as UTF-8, or ASCII (which is a subset of UTF-8)
+        [_, charSet] -> any (`T.isInfixOf` charSet) ["utf-8", "us-ascii"]
+        _ -> False
+
+      isInferredUTF8FromContentType = BS8.takeWhile (/= ';') contentTypeBS `Set.member` assumedUTF8ContentTypes
+
+  in isUTF8FromCharset || isInferredUTF8FromContentType
+
+-- | List of Content-Types that are assumed to be UTF-8 (e.g. JSON).
+--
+-- @since 1.6.10
+assumedUTF8ContentTypes :: Set.Set BS8.ByteString
+assumedUTF8ContentTypes = Set.fromList $ map Content.simpleContentType
+  [ Content.typeHtml
+  , Content.typePlain
+  , Content.typeJson
+  , Content.typeXml
+  , Content.typeAtom
+  , Content.typeRss
+  , Content.typeSvg
+  , Content.typeJavascript
+  , Content.typeCss
+  ]

yesod-test/Yesod/Test/Internal/SIO.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | The 'SIO' type is used by "Yesod.Test" to provide exception-safe
+-- environment between requests and assertions.
+--
+-- This module is internal. Breaking changes to this module will not be
+-- reflected in the major version of this package.
+--
+-- @since 1.6.13
+module Yesod.Test.Internal.SIO where
+
+import Control.Monad.Trans.Reader (ReaderT (..))
+import Conduit (MonadThrow)
+import qualified Control.Monad.State.Class as MS
+import Yesod.Core
+import Data.IORef
+
+-- | State + IO
+--
+-- @since 1.6.0
+newtype SIO s a = SIO (ReaderT (IORef s) IO a)
+  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
+
+instance MS.MonadState s (SIO s)
+  where
+  get = getSIO
+  put = putSIO
+
+-- | Retrieve the current state in the 'SIO' type.
+--
+-- Equivalent to 'MS.get'
+--
+-- @since 1.6.13
+getSIO :: SIO s s
+getSIO = SIO $ ReaderT readIORef
+
+-- | Put the given @s@ into the 'SIO' state for later retrieval.
+--
+-- Equivalent to 'MS.put', but the value is evaluated to weak head normal
+-- form.
+--
+-- @since 1.6.13
+putSIO :: s -> SIO s ()
+putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
+
+-- | Modify the underlying @s@ state.
+--
+-- This is strict in the function used, and is equivalent to 'MS.modify''.
+--
+-- @since 1.6.13
+modifySIO :: (s -> s) -> SIO s ()
+modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
+
+-- | Run an 'SIO' action with the intial state @s@ provided, returning the
+-- result, and discard the final state.
+--
+-- @since 1.6.13
+evalSIO :: SIO s a -> s -> IO a
+evalSIO action =
+    fmap snd . runSIO action
+
+-- | Run an 'SIO' action with the initial state @s@ provided, returning the
+-- final state, and discarding the result.
+--
+-- @since 1.6.13
+execSIO :: SIO s () -> s -> IO s
+execSIO action =
+    fmap fst . runSIO action
+
+-- | Run an 'SIO' action with the initial state provided, returning both
+-- the result of the computation as well as the final state.
+--
+-- @since 1.6.13
+runSIO :: SIO s a -> s -> IO (s, a)
+runSIO (SIO (ReaderT f)) s = do
+    ref <- newIORef s
+    a <- f ref
+    s' <- readIORef ref
+    pure (s', a)