Actually export the new options (#1825)

* actually export the new options

* bump version number, update changelog

.github/ISSUE_TEMPLATE.md

@@ -15,7 +15,7 @@ command -v sw_vers && sw_vers # OS X only
 command -v uname && uname -a # Kernel version
 command -v stack && stack --version
 command -v stack && stack ghc -- --version
-command -v stack && stack list-dependencies
+command -v stack && stack ls dependencies
 command -v yesod && yesod version
 ```
 

.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

@@ -4,6 +4,7 @@
 *.hi
 dist/
 dist-stack/
+stack.yaml.lock
 .stack-work
 *.swp
 client_session_key.aes
@@ -23,4 +24,6 @@ tarballs/
 .bash_history
 
 # OS X
-.DS_Store
+.DS_Store
+*.yaml.lock
+dist-newstyle/

.travis.yml

@@ -1,187 +0,0 @@
-# This is the complex Travis 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/travis_ci/
-#
-# Copy these contents into the root directory of your Github project in a file
-# named .travis.yml
-
-# Use new container infrastructure to enable caching
-sudo: false
-
-# Do not choose a language; we provide our own build tools.
-language: generic
-
-# Caching so the next build will be fast too.
-cache:
-  directories:
-  - $HOME/.ghc
-  - $HOME/.cabal
-  - $HOME/.stack
-
-# The different configurations we want to test. We have BUILD=cabal which uses
-# cabal-install, and BUILD=stack which uses Stack. More documentation on each
-# of those below.
-#
-# We set the compiler values here to tell Travis to use a different
-# cache file per set of arguments.
-#
-# If you need to have different apt packages for each combination in the
-# matrix, you can use a line such as:
-#     addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}
-matrix:
-  include:
-  # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:
-  # https://github.com/hvr/multi-ghc-travis
-  - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
-    compiler: ": #GHC 8.0.2"
-    addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
-  - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7
-    compiler: ": #GHC 8.2.2"
-    addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
-
-  # Build with the newest GHC and cabal-install. This is an accepted failure,
-  # see below.
-  - env: BUILD=cabal GHCVER=head  CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
-    compiler: ": #GHC HEAD"
-    addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
-
-  # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS
-  # variable, such as using --stack-yaml to point to a different file.
-  - env: BUILD=stack ARGS=""
-    compiler: ": #stack default"
-    addons: {apt: {packages: [libgmp-dev]}}
-
-  - env: BUILD=stack ARGS="--resolver lts-7"
-    compiler: ": #stack 8.0.1"
-    addons: {apt: {packages: [libgmp-dev]}}
-
-  - env: BUILD=stack ARGS="--resolver lts-9"
-    compiler: ": #stack 8.0.2"
-    addons: {apt: {packages: [libgmp-dev]}}
-
-  - env: BUILD=stack ARGS="--resolver lts-10"
-    compiler: ": #stack 8.2.2"
-    addons: {apt: {packages: [libgmp-dev]}}
-
-  # Nightly builds are allowed to fail
-  - env: BUILD=stack ARGS="--resolver nightly"
-    compiler: ": #stack nightly"
-    addons: {apt: {packages: [libgmp-dev]}}
-
-  # Build on macOS in addition to Linux
-  - env: BUILD=stack ARGS=""
-    compiler: ": #stack default osx"
-    os: osx
-
-  # malformed mach-o: load commands size (34184) > 32768)
-  #- env: BUILD=stack ARGS="--resolver lts-7"
-  #  compiler: ": #stack 8.0.1 osx"
-  #  os: osx
-
-  - env: BUILD=stack ARGS="--resolver lts-9"
-    compiler: ": #stack 8.0.2 osx"
-    os: osx
-
-  - env: BUILD=stack ARGS="--resolver lts-10"
-    compiler: ": #stack 8.2.2 osx"
-    os: osx
-
-  - env: BUILD=stack ARGS="--resolver nightly"
-    compiler: ": #stack nightly osx"
-    os: osx
-
-  allow_failures:
-  - env: BUILD=cabal GHCVER=head  CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
-  - env: BUILD=stack ARGS="--resolver nightly"
-
-before_install:
-# Using compiler above sets CC to an invalid value, so unset it
-- unset CC
-
-# We want to always allow newer versions of packages when building on GHC HEAD
-- CABALARGS=""
-- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi
-
-# Download and unpack the stack executable
-- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH
-- mkdir -p ~/.local/bin
-- |
-  if [ `uname` = "Darwin" ]
-  then
-    travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin
-  else
-    travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
-  fi
-
-  # Use the more reliable S3 mirror of Hackage
-  mkdir -p $HOME/.cabal
-  echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config
-  echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config
-
-  if [ "$CABALVER" != "1.16" ]
-  then
-    echo 'jobs: $ncpus' >> $HOME/.cabal/config
-  fi
-
-install:
-- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
-- if [ -f configure.ac ]; then autoreconf -i; fi
-- |
-  set -ex
-  case "$BUILD" in
-    stack)
-      # Add in extra-deps for older snapshots, as necessary
-      stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \
-        stack --no-terminal $ARGS build cabal-install && \
-        stack --no-terminal $ARGS solver --update-config)
-
-      # Build the dependencies
-      stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies
-      ;;
-    cabal)
-      cabal --version
-      travis_retry cabal update
-
-      # Get the list of packages from the stack.yaml file. Note that
-      # this will also implicitly run hpack as necessary to generate
-      # the .cabal files needed by cabal-install.
-      PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')
-
-      cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
-      ;;
-  esac
-  set +ex
-
-script:
-- |
-  set -ex
-  case "$BUILD" in
-    stack)
-      stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
-      ;;
-    cabal)
-      cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
-
-      # Times out
-      #ORIGDIR=$(pwd)
-      #for dir in $PACKAGES
-      #do
-      #  cd $dir
-      #  cabal check || [ "$CABALVER" == "1.16" ]
-      #  cabal sdist
-      #  PKGVER=$(cabal info . | awk '{print $2;exit}')
-      #  SRC_TGZ=$PKGVER.tar.gz
-      #  cd dist
-      #  tar zxfv "$SRC_TGZ"
-      #  cd "$PKGVER"
-      #  cabal configure --enable-tests --ghc-options -O0
-      #  cabal build
-      #  cabal test
-      #  cd $ORIGDIR
-      #done
-      ;;
-  esac
-  set +ex

README

@@ -1,15 +0,0 @@
-Authentication methods for Haskell web applications.
-
-Note for Rpxnow: 
-By default on some (all?) installs wget does not come with root certificates
-for SSL.  If this is the case then Web.Authenticate.Rpxnow.authenticate will
-fail as wget cannot establish a secure connection to rpxnow's servers.
-
-A simple *nix solution, if potentially insecure (man in the middle attacks as
-you are downloading the certs) is to grab a copy of the certs extracted from
-those that come with firefox, hosted by CURL at
-http://curl.haxx.se/ca/cacert.pem , put them somewhere (for ex,
-~/.wget/cacert.pem) and then edit your ~/.wgetrc to include:
-ca_certificate=~/.wget/cacert.pem
-
-This should fix the problem.

README.md

@@ -1,4 +1,4 @@
-[![Build Status](https://travis-ci.org/yesodweb/yesod.svg?branch=master)](https://travis-ci.org/yesodweb/yesod)
+![Tests](https://github.com/yesodweb/yesod/workflows/Tests/badge.svg)
 
 # Yesod Web Framework
 
@@ -12,20 +12,50 @@ An advanced web framework using the Haskell programming language. Featuring:
   * asynchronous IO
     * this is built in to the Haskell programming language (like Erlang)
 
+## Getting Started
+
 Learn more about Yesod on [its main website](http://www.yesodweb.com/). If you
 want to get started using Yesod, we strongly recommend the [quick start
 guide](http://www.yesodweb.com/page/quickstart), based on [the Haskell build
 tool stack](https://github.com/commercialhaskell/stack#readme).
 
+Here's a minimal example!
+
+```haskell
+{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies #-}
+
+import Yesod
+
+data App = App -- Put your config, database connection pool, etc. in here.
+
+-- Derive routes and instances for App.
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod App -- Methods in here can be overridden as needed.
+
+-- The handler for the GET request at /, corresponds to HomeR.
+getHomeR :: Handler Html
+getHomeR = defaultLayout [whamlet|Hello World!|]
+
+main :: IO ()
+main = warp 3000 App
+```
+
+To read about each of the concepts in use above (routing, handlers,
+linking, JSON), in detail, visit
+[Basics in the Yesod book](https://www.yesodweb.com/book/basics#basics_routing).
+
 ## Hacking on Yesod
 
 Yesod consists mostly of four repositories:
 
 ```bash
-git clone --recursive http://github.com/yesodweb/shakespeare
+git clone --recurse-submodules http://github.com/yesodweb/shakespeare
-git clone --recursive http://github.com/yesodweb/persistent
+git clone --recurse-submodules http://github.com/yesodweb/persistent
-git clone --recursive http://github.com/yesodweb/wai
+git clone --recurse-submodules http://github.com/yesodweb/wai
-git clone --recursive http://github.com/yesodweb/yesod
+git clone --recurse-submodules http://github.com/yesodweb/yesod
 ```
 
 Each repository can be built with `stack build`.

ReleaseNotes.md

@@ -1,5 +0,0 @@
-Release notes are maintained on the wiki.
-
-https://github.com/yesodweb/yesod/wiki/Changelog (high level features)
-
-https://github.com/yesodweb/yesod/wiki/Detailed-change-list (see for breaking changes)

appveyor.yml

@@ -1,19 +0,0 @@
-build: off
-
-before_test:
-# http://help.appveyor.com/discussions/problems/6312-curl-command-not-found
-- set PATH=C:\Program Files\Git\mingw64\bin;%PATH%
-
-- curl -sS -ostack.zip -L --insecure http://www.stackage.org/stack/windows-i386
-- 7z x stack.zip stack.exe
-
-clone_folder: "c:\\stack"
-environment:
-  global:
-    STACK_ROOT: "c:\\sr"
-
-test_script:
-- stack setup > nul
-# The ugly echo "" hack is to avoid complaints about 0 being an invalid file
-# descriptor
-- echo "" | stack --no-terminal test

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/auth/email_auth_ses_mailer.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -15,7 +14,6 @@ import           Data.Yaml
 import           Data.Text (Text)
 import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Lazy.Encoding as LTE
-import           Data.Typeable (Typeable)
 import           Database.Persist.Sqlite
 import           Database.Persist.TH
 import           Network.Mail.Mime
@@ -37,7 +35,6 @@ User
     verkey Text Maybe -- Used for resetting passwords
     verified Bool
     UniqueUser email
-    deriving Typeable
 |]
 
 data App = App

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.

sources.txt

@@ -1,13 +0,0 @@
-./yesod-core
-./yesod-static
-./yesod-persistent
-./yesod-newsfeed
-./yesod-form
-./yesod-auth
-./yesod-auth-oauth
-./yesod-sitemap
-./yesod-test
-./yesod-bin
-./yesod
-./yesod-eventsource
-./yesod-websockets

stack.yaml

@@ -1,45 +1,19 @@
-resolver: lts-8.12
+resolver: lts-18.3
 packages:
-  - ./yesod-core
+- ./yesod-core
-  - ./yesod-static
+- ./yesod-static
-  - ./yesod-persistent
+- ./yesod-persistent
-  - ./yesod-newsfeed
+- ./yesod-newsfeed
-  - ./yesod-form
+- ./yesod-form
-  - ./yesod-auth
+- ./yesod-form-multi
-  - ./yesod-auth-oauth
+- ./yesod-auth
-  - ./yesod-sitemap
+- ./yesod-auth-oauth
-  - ./yesod-test
+- ./yesod-sitemap
-  - ./yesod-bin
+- ./yesod-test
-  - ./yesod
+- ./yesod-bin
-  - ./yesod-eventsource
+- ./yesod
-  - ./yesod-websockets
+- ./yesod-eventsource
+- ./yesod-websockets
+
 extra-deps:
-- unliftio-core-0.1.1.0
+- attoparsec-aeson-2.1.0.0
-- unliftio-0.2.4.0
-- authenticate-1.3.4
-- typed-process-0.2.1.0
-- conduit-1.3.0
-- conduit-extra-1.3.0
-- persistent-2.8.0
-- resourcet-1.2.0
-- mono-traversable-1.0.8.1
-- yaml-0.8.28
-- project-template-0.2.0.1
-- xml-conduit-1.8.0
-- wai-extra-3.0.22.0
-- monad-logger-0.3.28.1
-- html-conduit-1.3.0
-- http-conduit-2.3.0
-- persistent-sqlite-2.8.0
-- cookie-0.4.3
-- gauge-0.2.1
-- basement-0.0.6
-- foundation-0.0.19
-- memory-0.14.14
-- simple-sendfile-0.2.27
-- aeson-1.2.4.0
-- http-client-0.5.10
-- http-client-tls-0.3.5.2
-- websockets-0.12.3.1
-- th-abstraction-0.2.6.0
-- persistent-template-2.5.3.1

stack.yaml.lock

@@ -0,0 +1,19 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+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:
+    sha256: 694573e96dca34db5636edb1fe6c96bb233ca0f9fb96c1ead1671cdfa9bd73e9
+    size: 585603
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/3.yaml
+  original: lts-18.3

yesod-auth-oauth/ChangeLog.md

@@ -1,3 +1,21 @@
+# 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
+
+## 1.6.0.1
+
+* Compile with GHC 8.6 [#1561](https://github.com/yesodweb/yesod/pull/1561)
+
 ## 1.6.0
 
 * Upgrade to yesod-core 1.6.0

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

@@ -1,5 +1,6 @@
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -17,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)
@@ -31,7 +31,7 @@ import           Yesod.Core
 
 data YesodOAuthException = CredentialError String Credential
                          | SessionError String
-                           deriving (Show, Typeable)
+                           deriving Show
 
 instance Exception YesodOAuthException
 
@@ -52,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
@@ -69,7 +64,9 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
         setSession oauthSessionName $ lookupTokenSecret tok
         redirect $ authorizeUrl oauth' tok
     dispatch "GET" [] = do
-      Just tokSec <- lookupSession oauthSessionName
+      tokSec <- lookupSession oauthSessionName >>= \case
+        Just t -> return t
+        Nothing -> liftIO $ fail "lookupSession could not find session"
       deleteSession oauthSessionName
       reqTok <-
         if oauthVersion oauth == OAuth10
@@ -127,7 +124,7 @@ authTwitter :: YesodAuth m
             -> ByteString -- ^ Consumer Secret
             -> AuthPlugin m
 authTwitter key secret = authTwitter' key secret "screen_name"
-{-# DEPRECATED authTwitter "Use authTwitterUsingUserID instead" #-}
+{-# DEPRECATED authTwitter "Use authTwitterUsingUserId instead" #-}
 
 -- | Twitter plugin which uses Twitter's /user_id/ as ID.
 --

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

@@ -1,5 +1,6 @@
+cabal-version:   >= 1.10
 name:            yesod-auth-oauth
-version:         1.6.0
+version:         1.6.1
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
@@ -7,28 +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
 
-flag ghc7
-
 library
-    if flag(ghc7)
+    default-language: Haskell2010
-        build-depends:   base                >= 4.3      && < 5
+    build-depends:   authenticate-oauth      >= 1.5       && < 1.8
-        cpp-options:     -DGHC7
+                   , base                    >= 4.10      && < 5
-    else
-        build-depends:   base                >= 4         && < 4.3
-    build-depends:   authenticate-oauth      >= 1.5       && < 1.7
                    , bytestring              >= 0.9.1.4
-                   , yesod-core              >= 1.6       && < 1.7
-                   , yesod-auth              >= 1.6       && < 1.7
                    , text                    >= 0.7
-                   , yesod-form              >= 1.6       && < 1.7
-                   , transformers            >= 0.2.2     && < 0.6
                    , unliftio
+                   , yesod-auth              >= 1.6       && < 1.7
+                   , yesod-core              >= 1.6       && < 1.7
+                   , yesod-form              >= 1.6       && < 1.8
     exposed-modules: Yesod.Auth.OAuth
     ghc-options:     -Wall
 

yesod-auth/ChangeLog.md

@@ -1,3 +1,95 @@
+# 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`
+* Fixed a bug in `getVerifyR` related to the above, where the incorrect message was displayed when password was set during registration
+* Added `sendForgotPasswordEmail` to `YesodAuthEmail` typeclass, allowing for different emails for account registration vs. forgot password
+* See pull request [#1662](https://github.com/yesodweb/yesod/pull/1662)
+
+## 1.6.9
+
+* Added `registerHelper` and `passwordResetHelper` methods to the `YesodAuthEmail` class, allowing for customizing behavior for user registration and forgot password requests [#1660](https://github.com/yesodweb/yesod/pull/1660)
+* Exposed `defaultRegisterHelper` as default implementation for the above methods
+
+## 1.6.8.1
+
+* Email: Fix typo in `defaultEmailLoginHandler` template [#1605](https://github.com/yesodweb/yesod/pull/1605)
+* Remove unnecessary deriving of Typeable
+
+## 1.6.8
+
+* Dummy: Add support for JSON submissions [#1619](https://github.com/yesodweb/yesod/pull/1619)
+
+## 1.6.7
+
+* Redirect behavior of `clearCreds` depends on request type [#1598](https://github.com/yesodweb/yesod/pull/1598)
+
+## 1.6.6
+
+* Deprecated `Yesod.Auth.GoogleEmail2`, see [#1579](https://github.com/yesodweb/yesod/issues/1579) and [migration blog post](https://pbrisbin.com/posts/googleemail2_deprecation/)
+
+## 1.6.5
+
+* Add support for persistent 2.9 [#1516](https://github.com/yesodweb/yesod/pull/1516), [#1561](https://github.com/yesodweb/yesod/pull/1561)
+
+## 1.6.4.1
+
+* Email: Fix forgot-password endpoint [#1537](https://github.com/yesodweb/yesod/pull/1537)
+
+## 1.6.4
+
+* Make `registerHelper` configurable [#1524](https://github.com/yesodweb/yesod/issues/1524)
+* Email: Immediately register with a password [#1389](https://github.com/yesodweb/yesod/issues/1389)
+To configure this new functionality:
+  1. Define `addUnverifiedWithPass`, e.g:
+  ```
+  addUnverified email verkey = liftHandler $ runDB $ do
+    void $ insert $ UserLogin email Nothing (Just verkey) False
+    return email
+
+  addUnverifiedWithPass email verkey pass = liftHandler $ runDB $ do
+    void $ insert $ UserLogin email (Just pass) (Just verkey) False
+    return email
+  ```
+  2. Add a `password` field to your client forms.
+
+## 1.6.3
+
+* Generalize GoogleEmail2.getPerson [#1501](https://github.com/yesodweb/yesod/pull/1501)
+
 ## 1.6.2
 
 * Remove MINIMAL praggma for authHttpManager [#1489](https://github.com/yesodweb/yesod/issues/1489)

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

@@ -8,7 +8,6 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Yesod.Auth
@@ -53,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)
@@ -75,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
 
@@ -421,14 +420,20 @@ authLayoutJson w json = selectRep $ do
 --
 -- @since 1.1.7
 clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
-           => Bool -- ^ if HTTP redirect to 'logoutDest' should be done
+           => Bool -- ^ if HTTP, redirect to 'logoutDest'
            -> m ()
 clearCreds doRedirects = do
-    y <- getYesod
     onLogout
     deleteSession credsKey
-    when doRedirects $ do
+    y  <- getYesod
-        redirectUltDest $ logoutDest y
+    aj <- acceptsJson
+    case (aj, doRedirects) of
+      (True, _)               -> sendResponse successfulLogout
+      (False, True)           -> redirectUltDest (logoutDest y)
+      _                       -> return ()
+    where successfulLogout = object ["message" .= msg]
+          msg :: Text
+          msg = "Logged out successfully!"
 
 getCheckR :: AuthHandler master TypedContent
 getCheckR = do
@@ -447,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)
             ]
 
@@ -509,7 +514,6 @@ maybeAuthPair = runMaybeT $ do
 
 
 newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
-    deriving Typeable
 
 -- | Class which states that the given site is an instance of @YesodAuth@
 -- and that its @AuthId@ is a lookup key for the full user information in
@@ -529,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)
@@ -601,7 +605,7 @@ instance YesodAuth master => RenderMessage master AuthMessage where
     renderMessage = renderAuthMessage
 
 data AuthException = InvalidFacebookResponse
-    deriving (Show, Typeable)
+    deriving Show
 instance Exception AuthException
 
 instance YesodAuth master => YesodSubDispatch Auth master where

yesod-auth/Yesod/Auth/Dummy.hs

@@ -1,25 +1,67 @@
-{-# 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
--- his/her identifier. This is not intended for real world use, just for
+-- their identifier. This is not intended for real world use, just for
--- testing.
+-- testing. This plugin supports form submissions via JSON (since 1.6.8).
+--
+-- = Using the JSON Login Endpoint
+--
+-- We are assuming that you have declared `authRoute` as follows
+--
+-- @
+--       Just $ AuthR LoginR
+-- @
+--
+-- If you are using a different one, then you have to adjust the
+-- endpoint accordingly.
+--
+-- @
+--       Endpoint: \/auth\/page\/dummy
+--       Method: POST
+--       JSON Data: {
+--                      "ident": "my identifier"
+--                  }
+-- @
+--
+-- Remember to add the following headers:
+--
+--     - Accept: application\/json
+--     - Content-Type: application\/json
+
 module Yesod.Auth.Dummy
     ( authDummy
     ) where
 
-import Yesod.Auth
+import           Data.Aeson.Types (Parser, Result (..))
-import Yesod.Form (runInputPost, textField, ireq)
+import qualified Data.Aeson.Types as A (parseEither, withObject)
-import Yesod.Core
+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")
 
 authDummy :: YesodAuth m => AuthPlugin m
 authDummy =
     AuthPlugin "dummy" dispatch login
   where
+    dispatch :: Text -> [Text] -> AuthHandler m TypedContent
     dispatch "POST" [] = do
-        ident <- runInputPost $ ireq textField "ident"
+        (jsonResult :: Result Value) <- parseCheckJsonBody
-        setCredsRedirect $ Creds "dummy" ident []
+        eIdent <- case jsonResult of
+            Success val -> return $ A.parseEither identParser val
+            Error   err -> return $ Left err
+        case eIdent of
+            Right ident ->
+                setCredsRedirect $ Creds "dummy" ident []
+            Left  _     -> do
+                ident <- runInputPost $ ireq textField "ident"
+                setCredsRedirect $ Creds "dummy" ident []
     dispatch _ _ = notFound
     url = PluginR "dummy" []
     login authToMaster = do

yesod-auth/Yesod/Auth/Email.hs

@@ -31,24 +31,27 @@
 -- = Using JSON Endpoints
 --
 -- We are assuming that you have declared auth route as follows
--- 
+--
 -- @
 --    /auth AuthR Auth getAuth
 -- @
--- 
+--
 -- If you are using a different route, then you have to adjust the
 -- endpoints accordingly.
 --
 --     * Registration
--- 
+--
 -- @
 --       Endpoint: \/auth\/page\/email\/register
 --       Method: POST
---       JSON Data: { "email": "myemail@domain.com" }
+--       JSON Data: {
+--                      "email": "myemail@domain.com",
+--                      "password": "myStrongPassword" (optional)
+--                  }
 -- @
--- 
+--
 --     * Forgot password
---  
+--
 -- @
 --       Endpoint: \/auth\/page\/email\/forgot-password
 --       Method: POST
@@ -56,16 +59,16 @@
 -- @
 --
 --     * Login
---  
+--
 -- @
 --       Endpoint: \/auth\/page\/email\/login
 --       Method: POST
---       JSON Data: { 
+--       JSON Data: {
 --                      "email": "myemail@domain.com",
 --                      "password": "myStrongPassword"
 --                  }
 -- @
--- 
+--
 --     * Set new password
 --
 -- @
@@ -110,30 +113,34 @@ module Yesod.Auth.Email
     , defaultRegisterHandler
     , defaultForgotPasswordHandler
     , defaultSetPasswordHandler
+     -- * Default helpers
+    , 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"]
@@ -141,11 +148,15 @@ registerR = PluginR "email" ["register"]
 forgotPasswordR = PluginR "email" ["forgot-password"]
 setpassR = PluginR "email" ["set-password"]
 
+verifyURLHasSetPassText :: Text
+verifyURLHasSetPassText = "has-set-pass"
+
 -- |
 --
 -- @since 1.4.5
-verifyR :: Text -> Text -> AuthRoute -- FIXME
+verifyR :: Text -> Text -> Bool -> AuthRoute -- FIXME
-verifyR eid verkey = PluginR "email" ["verify", eid, verkey]
+verifyR eid verkey hasSetPass = PluginR "email" path
+    where path = "verify":eid:verkey:(if hasSetPass then [verifyURLHasSetPassText] else [])
 
 type Email = Text
 type VerKey = Text
@@ -188,11 +199,33 @@ class ( YesodAuth site
     -- @since 1.1.0
     addUnverified :: Email -> VerKey -> AuthHandler site (AuthEmailId site)
 
+    -- | Similar to `addUnverified`, but comes with the registered password.
+    --
+    -- The default implementation is just `addUnverified`, which ignores the password.
+    --
+    -- You may override this to save the salted password to your database.
+    --
+    -- @since 1.6.4
+    addUnverifiedWithPass :: Email -> VerKey -> SaltedPass -> AuthHandler site (AuthEmailId site)
+    addUnverifiedWithPass email verkey _ = addUnverified email verkey
+
     -- | Send an email to the given address to verify ownership.
     --
     -- @since 1.1.0
     sendVerifyEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()
 
+    -- | Send an email to the given address to re-verify ownership in the case of
+    -- a password reset. This can be used to send a different email when a user
+    -- goes through the 'forgot password' flow as opposed to the 'account registration'
+    -- flow.
+    --
+    -- Default: Will call 'sendVerifyEmail', resulting in the same email getting sent
+    -- for both registrations and password resets.
+    --
+    -- @since 1.6.10
+    sendForgotPasswordEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()
+    sendForgotPasswordEmail = sendVerifyEmail
+
     -- | Get the verification key for the given email ID.
     --
     -- @since 1.1.0
@@ -209,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.
     --
@@ -262,6 +295,12 @@ class ( YesodAuth site
     -- @since 1.2.0
     afterPasswordRoute :: site -> Route site
 
+    -- | Route to send user to after verification with a password
+    --
+    -- @since 1.6.4
+    afterVerificationWithPass :: site -> Route site
+    afterVerificationWithPass = afterPasswordRoute
+
     -- | Does the user need to provide the current password in order to set a
     -- new password?
     --
@@ -299,6 +338,14 @@ class ( YesodAuth site
       where
         msg = Msg.ConfirmationEmailSent identifier
 
+    -- | If a response is set, it will be used when an already-verified email
+    -- tries to re-register. Otherwise, `confirmationEmailSentResponse` will be
+    -- used.
+    --
+    -- @since 1.6.4
+    emailPreviouslyRegisteredResponse :: MonadAuthHandler site m => Text -> Maybe (m TypedContent)
+    emailPreviouslyRegisteredResponse _ = Nothing
+
     -- | Additional normalization of email addresses, besides standard canonicalization.
     --
     -- Default: Lower case the email address.
@@ -354,18 +401,52 @@ class ( YesodAuth site
       -> AuthHandler site TypedContent
     setPasswordHandler = defaultSetPasswordHandler
 
+
+    -- | Helper that controls what happens after a user registration
+    -- request is submitted. This method can be overridden to completely
+    -- customize what happens during the user registration process,
+    -- such as for handling additional fields in the registration form.
+    --
+    -- The default implementation is in terms of 'defaultRegisterHelper'.
+    --
+    -- @since: 1.6.9
+    registerHelper :: Route Auth
+                      -- ^ Where to sent the user in the event
+                      -- that registration fails
+                   -> AuthHandler site TypedContent
+    registerHelper = defaultRegisterHelper False False
+
+    -- | Helper that controls what happens after a forgot password
+    -- request is submitted. As with `registerHelper`, this method can
+    -- be overridden to customize the behavior when a user attempts
+    -- to recover their password.
+    --
+    -- The default implementation is in terms of 'defaultRegisterHelper'.
+    --
+    -- @since: 1.6.9
+    passwordResetHelper :: Route Auth
+                           -- ^ Where to sent the user in the event
+                           -- that the password reset fails
+                        -> AuthHandler site TypedContent
+    passwordResetHelper = defaultRegisterHelper True True
+
 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
+            Just eid' -> getVerifyR eid' verkey False >>= sendResponse
+    dispatch "GET" ["verify", eid, verkey, hasSetPass] =
         case fromPathPiece eid of
             Nothing -> notFound
-            Just eid' -> getVerifyR eid' verkey >>= sendResponse
+            Just eid' -> getVerifyR eid' verkey (hasSetPass == verifyURLHasSetPassText) >>= sendResponse
     dispatch "POST" ["login"] = postLoginR >>= sendResponse
     dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse
     dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse
@@ -385,7 +466,7 @@ defaultEmailLoginHandler toParent = do
         (widget, enctype) <- generateFormPost loginForm
 
         [whamlet|
-            <form method="post" action="@{toParent loginR}", enctype=#{enctype}>
+            <form method="post" action="@{toParent loginR}" enctype=#{enctype}>
                 <div id="emailLoginForm">
                     ^{widget}
                     <div>
@@ -407,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
@@ -467,70 +548,94 @@ defaultRegisterHandler = do
 
             let userRes = UserForm <$> emailRes
             let widget = do
-                [whamlet|
+                  [whamlet|
-                    #{extra}
+                      #{extra}
-                    ^{fvLabel emailView}
+                      ^{fvLabel emailView}
-                    ^{fvInput emailView}
+                      ^{fvInput emailView}
-                |]
+                  |]
 
             return (userRes, widget)
 
-parseEmail :: Value -> Parser Text
+parseRegister :: Value -> Parser (Text, Maybe Text)
-parseEmail = withObject "email" (\obj -> do
+parseRegister = withObject "email" (\obj -> do
-                                   email' <- obj .: "email"
+                                      email <- obj .: "email"
-                                   return email')
+                                      pass <- obj .:? "password"
+                                      return (email, pass))
 
-registerHelper :: YesodAuthEmail master
+defaultRegisterHelper :: YesodAuthEmail master
-               => Bool -- ^ allow usernames?
+                      => Bool -- ^ Allow lookup via username in addition to email
-               -> Route Auth
+                      -> Bool -- ^ Set to `True` for forgot password flow, `False` for new account registration
-               -> AuthHandler master TypedContent
+                      -> Route Auth
-registerHelper allowUsername dest = do
+                      -> AuthHandler master TypedContent
+defaultRegisterHelper allowUsername forgotPassword dest = do
     y <- getYesod
     checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
-    pidentifier <- lookupPostParam "email"
+    result <- runInputPostResult $ (,)
-    midentifier <- case pidentifier of
+        <$> ireq textField "email"
-                     Nothing -> do
+        <*> iopt textField "password"
-                       (jidentifier :: Result Value) <- parseCheckJsonBody
+
-                       case jidentifier of
+    creds <- case result of
-                         Error _ -> return Nothing
+                 FormSuccess (iden, pass) -> return $ Just (iden, pass)
-                         Success val -> return $ parseMaybe parseEmail val
+                 _ -> do
-                     Just _ -> return pidentifier
+                     (creds :: Result Value) <- parseCheckJsonBody
-    let eidentifier = case midentifier of
+                     return $ case creds of
+                                  Error _     -> Nothing
+                                  Success val -> parseMaybe parseRegister val
+
+    let eidentifier = case creds of
                           Nothing -> Left Msg.NoIdentifierProvided
-                          Just x
+                          Just (x, _)
                               | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->
                                          Right $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'
                               | allowUsername -> Right $ TS.strip x
                               | otherwise -> Left Msg.InvalidEmailAddress
+
+    let mpass = case (forgotPassword, creds) of
+                    (False, Just (_, mp)) -> mp
+                    _                     -> Nothing
+
     case eidentifier of
-      Left route -> loginErrorMessageI dest route
+      Left failMsg -> loginErrorMessageI dest failMsg
       Right identifier -> do
             mecreds <- getEmailCreds identifier
             registerCreds <-
                 case mecreds of
-                    Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
+                    Just (EmailCreds lid _ verStatus (Just key) email) -> return $ Just (lid, verStatus, key, email)
-                    Just (EmailCreds lid _ _ Nothing email) -> do
+                    Just (EmailCreds lid _ verStatus Nothing email) -> do
                         key <- liftIO $ randomKey y
                         setVerifyKey lid key
-                        return $ Just (lid, key, email)
+                        return $ Just (lid, verStatus, key, email)
                     Nothing
                         | allowUsername -> return Nothing
                         | otherwise -> do
                             key <- liftIO $ randomKey y
-                            lid <- addUnverified identifier key
+                            lid <- case mpass of
-                            return $ Just (lid, key, identifier)
+                                Just pass -> do
-
+                                    salted <- hashAndSaltPassword pass
+                                    addUnverifiedWithPass identifier key salted
+                                _ -> addUnverified identifier key
+                            return $ Just (lid, False, key, identifier)
             case registerCreds of
                 Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
-                Just (lid, verKey, email) -> do
+                Just creds@(_, False, _, _) -> sendConfirmationEmail creds
-                    render <- getUrlRender
+                Just creds@(_, True, _, _) -> do
-                    tp <- getRouteToParent
+                  if forgotPassword
-                    let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey
+                    then sendConfirmationEmail creds
-                    sendVerifyEmail email verKey verUrl
+                    else case emailPreviouslyRegisteredResponse identifier of
-                    confirmationEmailSentResponse identifier
+                      Just response -> response
+                      Nothing       -> sendConfirmationEmail creds
+              where sendConfirmationEmail (lid, _, verKey, email) = do
+                      render <- getUrlRender
+                      tp <- getRouteToParent
+                      let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey (isJust mpass)
+                      if forgotPassword
+                         then sendForgotPasswordEmail email verKey verUrl
+                         else sendVerifyEmail email verKey verUrl
+                      confirmationEmailSentResponse identifier
+
 
 postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
-postRegisterR = registerHelper False registerR
+postRegisterR = registerHelper registerR
 
 getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html
 getForgotPasswordR = forgotPasswordHandler
@@ -557,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 =
@@ -574,13 +679,14 @@ defaultForgotPasswordHandler = do
         }
 
 postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
-postForgotPasswordR = registerHelper True forgotPasswordR
+postForgotPasswordR = passwordResetHelper forgotPasswordR
 
 getVerifyR :: YesodAuthEmail site
            => AuthEmailId site
            -> Text
+           -> Bool
            -> AuthHandler site TypedContent
-getVerifyR lid key = do
+getVerifyR lid key hasSetPass = do
     realKey <- getVerifyKey lid
     memail <- getEmail lid
     mr <- getMessageRender
@@ -592,12 +698,20 @@ getVerifyR lid key = do
                 Just uid -> do
                     setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
                     setLoginLinkKey uid
-                    let msgAv = Msg.AddressVerified
+                    let msgAv = if hasSetPass
+                                  then Msg.EmailVerified
+                                  else Msg.EmailVerifiedChangePass
                     selectRep $ do
                       provideRep $ do
                         addMessageI "success" msgAv
-                        tp <- getRouteToParent
+                        redirectRoute <- if hasSetPass
-                        fmap asHtml $ redirect $ tp setpassR
+                            then do
+                              y <- getYesod
+                              return $ afterVerificationWithPass y
+                            else do
+                              tp <- getRouteToParent
+                              return $ tp setpassR
+                        fmap asHtml $ redirect redirectRoute
                       provideJsonMessage $ mr msgAv
         _ -> invalidKey mr
   where
@@ -628,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
@@ -668,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'.
@@ -697,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 =
@@ -759,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
@@ -771,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
@@ -790,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"
@@ -801,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) ->
@@ -821,7 +935,7 @@ postPasswordR = do
 
                      mr <- getMessageRender
                      selectRep $ do
-                         provideRep $ 
+                         provideRep $
                             fmap asHtml $ redirect $ afterPasswordRoute y
                          provideJsonMessage (mr msgOk)
 

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -26,6 +26,7 @@
 --
 -- @since 1.3.1
 module Yesod.Auth.GoogleEmail2
+    {-# DEPRECATED "Google+ is being shut down, please migrate to Google Sign-in https://pbrisbin.com/posts/googleemail2_deprecation/" #-}
     ( -- * Authentication handlers
       authGoogleEmail
     , authGoogleEmailSaveToken
@@ -52,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
@@ -238,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'
@@ -246,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
@@ -270,7 +279,7 @@ makeHttpRequest req =
 --   Will throw 'HttpException' in case of network problems or error response code.
 --
 -- @since 1.4.3
-getPerson :: Manager -> Token -> AuthHandler site (Maybe Person)
+getPerson :: MonadHandler m => Manager -> Token -> m (Maybe Person)
 getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do
     req <- personValueRequest token
     res <- http req manager
@@ -449,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.
@@ -584,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

@@ -52,7 +52,7 @@ be unique).
 'AuthId' must have an instance of 'PathPiece' class, this is needed to store
 user identifier in session (this happens in 'setCreds' and 'setCredsRedirect'
 actions) and to read that identifier from session (this happens in
-`dafaultMaybeAuthId` action).  So we have to define it:
+`defaultMaybeAuthId` action).  So we have to define it:
 
 @
 import Text.Read (readMaybe)
@@ -85,7 +85,7 @@ Here @lookupUser@ is just a helper function to lookup hardcoded users by name:
 
 @
 lookupUser :: Text -> Maybe SiteManager
-lookupUser username = find (\m -> manUserName m == username) siteManagers
+lookupUser username = find (\\m -> manUserName m == username) siteManagers
 @
 
 
@@ -113,7 +113,7 @@ instance YesodAuthHardcoded App where
 
 validPassword :: Text -> Text -> Bool
 validPassword u p =
-  case find (\m -> manUserName m == u && manPassWord m == p) siteManagers of
+  case find (\\m -> manUserName m == u && manPassWord m == p) siteManagers of
     Just _ -> True
     _      -> False
 @
@@ -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

@@ -40,6 +40,8 @@ data AuthMessage =
     | ConfirmationEmailSentTitle
     | ConfirmationEmailSent Text
     | AddressVerified
+    | EmailVerifiedChangePass
+    | EmailVerified
     | InvalidKeyTitle
     | InvalidKey
     | InvalidEmailPass
@@ -69,6 +71,7 @@ data AuthMessage =
     | LogoutTitle
     | AuthError
 {-# DEPRECATED Logout "Please, use LogoutTitle instead." #-}
+{-# DEPRECATED AddressVerified "Please, use EmailVerifiedChangePass instead." #-}
 
 -- | Defaults to 'englishMessage'.
 defaultMessage :: AuthMessage -> Text
@@ -91,7 +94,9 @@ englishMessage (ConfirmationEmailSent email) =
     "A confirmation e-mail has been sent to " `Data.Monoid.mappend`
     email `mappend`
     "."
-englishMessage AddressVerified = "Address verified, please set a new password"
+englishMessage AddressVerified = "Email address verified, please set a new password"
+englishMessage EmailVerifiedChangePass = "Email address verified, please set a new password"
+englishMessage EmailVerified = "Email address verified"
 englishMessage InvalidKeyTitle = "Invalid verification key"
 englishMessage InvalidKey = "I'm sorry, but that was an invalid verification key."
 englishMessage InvalidEmailPass = "Invalid email/password combination"
@@ -139,6 +144,8 @@ portugueseMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 portugueseMessage AddressVerified = "Endereço verificado, por favor entre com uma nova senha"
+portugueseMessage EmailVerifiedChangePass = "Endereço verificado, por favor entre com uma nova senha"
+portugueseMessage EmailVerified = "Endereço verificado"
 portugueseMessage InvalidKeyTitle = "Chave de verificação inválida"
 portugueseMessage InvalidKey = "Por favor nos desculpe, mas essa é uma chave de verificação inválida."
 portugueseMessage InvalidEmailPass = "E-mail e/ou senha inválidos"
@@ -187,6 +194,8 @@ spanishMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 spanishMessage AddressVerified = "Dirección verificada, por favor introduzca una contraseña"
+spanishMessage EmailVerifiedChangePass = "Dirección verificada, por favor introduzca una contraseña"
+spanishMessage EmailVerified = "Dirección verificada"
 spanishMessage InvalidKeyTitle = "Clave de verificación invalida"
 spanishMessage InvalidKey = "Lo sentimos, pero esa clave de verificación es inválida."
 spanishMessage InvalidEmailPass = "La combinación cuenta de correo/contraseña es inválida"
@@ -235,6 +244,8 @@ swedishMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 swedishMessage AddressVerified = "Adress verifierad, vänligen välj nytt lösenord"
+swedishMessage EmailVerifiedChangePass = "Adress verifierad, vänligen välj nytt lösenord"
+swedishMessage EmailVerified = "Adress verifierad"
 swedishMessage InvalidKeyTitle = "Ogiltig verifikationsnyckel"
 swedishMessage InvalidKey = "Tyvärr, du angav en ogiltig verifimationsnyckel."
 swedishMessage InvalidEmailPass = "Ogiltig epost/lösenord kombination"
@@ -271,19 +282,21 @@ 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`
     email `mappend`
     " versandt."
 germanMessage AddressVerified = "Adresse bestätigt, bitte neues Passwort angeben"
+germanMessage EmailVerifiedChangePass = "Adresse bestätigt, bitte neues Passwort angeben"
+germanMessage EmailVerified = "Adresse bestätigt"
 germanMessage InvalidKeyTitle = "Ungültiger Bestätigungsschlüssel"
 germanMessage InvalidKey = "Das war leider ein ungültiger Bestätigungsschlüssel"
 germanMessage InvalidEmailPass = "Ungültiger Nutzername oder Passwort"
@@ -295,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é"
@@ -332,6 +344,8 @@ frenchMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 frenchMessage AddressVerified = "Votre adresse électronique a été validée, merci de choisir un nouveau mot de passe."
+frenchMessage EmailVerifiedChangePass = "Votre adresse électronique a été validée, merci de choisir un nouveau mot de passe."
+frenchMessage EmailVerified = "Votre adresse électronique a été validée"
 frenchMessage InvalidKeyTitle = "Clef de validation incorrecte"
 frenchMessage InvalidKey = "Désolé, mais cette clef de validation est incorrecte"
 frenchMessage InvalidEmailPass = "La combinaison de ce mot de passe et de cette adresse électronique n'existe pas."
@@ -379,6 +393,8 @@ norwegianBokmålMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 norwegianBokmålMessage AddressVerified = "Adresse verifisert, vennligst sett et nytt passord."
+norwegianBokmålMessage EmailVerifiedChangePass = "Adresse verifisert, vennligst sett et nytt passord."
+norwegianBokmålMessage EmailVerified = "Adresse verifisert"
 norwegianBokmålMessage InvalidKeyTitle = "Ugyldig verifiseringsnøkkel"
 norwegianBokmålMessage InvalidKey = "Beklager, men det var en ugyldig verifiseringsnøkkel."
 norwegianBokmålMessage InvalidEmailPass = "Ugyldig e-post/passord-kombinasjon"
@@ -427,6 +443,8 @@ japaneseMessage (ConfirmationEmailSent email) =
     email `mappend`
     " に送信しました"
 japaneseMessage AddressVerified = "アドレスは認証されました。新しいパスワードを設定してください"
+japaneseMessage EmailVerifiedChangePass = "アドレスは認証されました。新しいパスワードを設定してください"
+japaneseMessage EmailVerified = "アドレスは認証されました"
 japaneseMessage InvalidKeyTitle = "認証キーが無効です"
 japaneseMessage InvalidKey = "申し訳ありません。無効な認証キーです"
 japaneseMessage InvalidEmailPass = "メールアドレスまたはパスワードが無効です"
@@ -476,6 +494,8 @@ finnishMessage (ConfirmationEmailSent email) =
     "."
 
 finnishMessage AddressVerified = "Sähköpostiosoite vahvistettu. Anna uusi salasana"
+finnishMessage EmailVerifiedChangePass = "Sähköpostiosoite vahvistettu. Anna uusi salasana"
+finnishMessage EmailVerified = "Sähköpostiosoite vahvistettu"
 finnishMessage InvalidKeyTitle = "Virheellinen varmistusavain"
 finnishMessage InvalidKey = "Valitettavasti varmistusavain on virheellinen."
 finnishMessage InvalidEmailPass = "Virheellinen sähköposti tai salasana."
@@ -524,6 +544,8 @@ chineseMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 chineseMessage AddressVerified = "地址验证成功，请设置新密码"
+chineseMessage EmailVerifiedChangePass = "地址验证成功，请设置新密码"
+chineseMessage EmailVerified = "地址验证成功"
 chineseMessage InvalidKeyTitle = "无效的验证码"
 chineseMessage InvalidKey = "对不起，验证码无效。"
 chineseMessage InvalidEmailPass = "无效的邮箱/密码组合"
@@ -569,6 +591,8 @@ czechMessage ConfirmationEmailSentTitle = "Potvrzovací e-mail odeslán"
 czechMessage (ConfirmationEmailSent email) =
     "Potvrzovací e-mail byl odeslán na " `mappend` email `mappend` "."
 czechMessage AddressVerified = "Adresa byla ověřena, prosím nastavte si nové heslo"
+czechMessage EmailVerifiedChangePass = "Adresa byla ověřena, prosím nastavte si nové heslo"
+czechMessage EmailVerified = "Adresa byla ověřena"
 czechMessage InvalidKeyTitle = "Neplatný ověřovací klíč"
 czechMessage InvalidKey = "Bohužel, ověřovací klíč je neplatný."
 czechMessage InvalidEmailPass = "Neplatná kombinace e-mail/heslo"
@@ -609,7 +633,7 @@ russianMessage LoginYahoo = "Вход с помощью Yahoo"
 russianMessage Email = "Эл.почта"
 russianMessage UserName = "Имя пользователя"
 russianMessage Password = "Пароль"
-russianMessage CurrentPassword = "Current password"
+russianMessage CurrentPassword = "Старый пароль"
 russianMessage Register = "Регистрация"
 russianMessage RegisterLong = "Создать учётную запись"
 russianMessage EnterEmail = "Введите свой адрес эл.почты ниже, вам будет отправлено письмо для подтверждения."
@@ -619,6 +643,8 @@ russianMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 russianMessage AddressVerified = "Адрес подтверждён. Пожалуйста, установите новый пароль."
+russianMessage EmailVerifiedChangePass = "Адрес подтверждён. Пожалуйста, установите новый пароль."
+russianMessage EmailVerified = "Адрес подтверждён"
 russianMessage InvalidKeyTitle = "Неверный ключ подтверждения"
 russianMessage InvalidKey = "Извините, но ключ подтверждения оказался недействительным."
 russianMessage InvalidEmailPass = "Неверное сочетание эл.почты и пароля"
@@ -666,6 +692,8 @@ dutchMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 dutchMessage AddressVerified = "Adres geverifieerd, stel alstublieft een nieuwe wachtwoord in"
+dutchMessage EmailVerifiedChangePass = "Adres geverifieerd, stel alstublieft een nieuwe wachtwoord in"
+dutchMessage EmailVerified = "Adres geverifieerd"
 dutchMessage InvalidKeyTitle = "Ongeldig verificatietoken"
 dutchMessage InvalidKey = "Dat was helaas een ongeldig verificatietoken."
 dutchMessage InvalidEmailPass = "Ongeldige e-mailadres/wachtwoord combinatie"
@@ -713,6 +741,8 @@ croatianMessage PasswordResetPrompt = "Dolje unesite adresu e-pošte ili korisni
 croatianMessage ConfirmationEmailSentTitle = "E-poruka za potvrdu"
 croatianMessage (ConfirmationEmailSent email) = "E-poruka za potvrdu poslana je na adresu " <> email <> "."
 croatianMessage AddressVerified = "Adresa ovjerena, postavite novu lozinku"
+croatianMessage EmailVerifiedChangePass = "Adresa ovjerena, postavite novu lozinku"
+croatianMessage EmailVerified = "Adresa ovjerena"
 croatianMessage InvalidKeyTitle = "Ključ za ovjeru nije valjan"
 croatianMessage InvalidKey = "Nažalost, taj ključ za ovjeru nije valjan."
 croatianMessage InvalidEmailPass = "Kombinacija e-pošte i lozinke nije valjana"
@@ -757,6 +787,8 @@ danishMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 danishMessage AddressVerified = "Adresse bekræftet, sæt venligst et nyt kodeord"
+danishMessage EmailVerifiedChangePass = "Adresse bekræftet, sæt venligst et nyt kodeord"
+danishMessage EmailVerified = "Adresse bekræftet"
 danishMessage InvalidKeyTitle = "Ugyldig verifikationsnøgle"
 danishMessage InvalidKey = "Beklager, det var en ugyldigt verifikationsnøgle."
 danishMessage InvalidEmailPass = "Ugyldigt e-mail/kodeord"
@@ -804,6 +836,8 @@ koreanMessage (ConfirmationEmailSent email) =
     email `mappend`
     "에 보냈습니다."
 koreanMessage AddressVerified = "주소가 인증되었습니다. 새 비밀번호를 설정하세요."
+koreanMessage EmailVerifiedChangePass = "주소가 인증되었습니다. 새 비밀번호를 설정하세요."
+koreanMessage EmailVerified = "주소가 인증되었습니다"
 koreanMessage InvalidKeyTitle = "인증키가 잘못되었습니다"
 koreanMessage InvalidKey = "죄송합니다. 잘못된 인증키입니다."
 koreanMessage InvalidEmailPass = "이메일 주소나 비밀번호가 잘못되었습니다"

yesod-auth/Yesod/Auth/Routes.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE ViewPatterns #-}
 module Yesod.Auth.Routes where
 

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,6 @@
+cabal-version:   >=1.10
 name:            yesod-auth
-version:         1.6.2
+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,55 +20,49 @@ flag network-uri
   default: True
 
 library
-    build-depends:   base                    >= 4         && < 5
+    default-language: Haskell2010
+    build-depends:   base                    >= 4.10      && < 5
+                   , aeson                   >= 0.7
+                   , attoparsec-aeson        >= 2.1
                    , authenticate            >= 1.3.4
-                   , bytestring              >= 0.9.1.4
-                   , yesod-core              >= 1.6       && < 1.7
-                   , wai                     >= 1.4
-                   , template-haskell
                    , base16-bytestring
-                   , cryptonite
+                   , base64-bytestring
-                   , memory
+                   , binary
-                   , random                  >= 1.0.0.2
+                   , blaze-builder
-                   , text                    >= 0.7
+                   , blaze-html              >= 0.5
-                   , mime-mail               >= 0.3
+                   , blaze-markup            >= 0.5.1
-                   , yesod-persistent        >= 1.6
+                   , bytestring              >= 0.9.1.4
-                   , shakespeare
+                   , conduit                 >= 1.3
+                   , conduit-extra
                    , containers
-                   , unordered-containers
+                   , cryptonite
-                   , yesod-form              >= 1.6       && < 1.7
+                   , data-default
-                   , transformers            >= 0.2.2
+                   , email-validate          >= 1.0
-                   , persistent              >= 2.8       && < 2.9
+                   , file-embed
-                   , persistent-template     >= 2.1       && < 2.8
                    , http-client             >= 0.5
                    , http-client-tls
                    , http-conduit            >= 2.1
-                   , aeson                   >= 0.7
-                   , unliftio
-                   , blaze-html              >= 0.5
-                   , blaze-markup            >= 0.5.1
                    , http-types
-                   , file-embed
+                   , memory
-                   , email-validate          >= 1.0
-                   , data-default
-                   , resourcet
-                   , safe
-                   , time
-                   , base64-bytestring
-                   , byteable
-                   , binary
-                   , http-client
-                   , blaze-builder
-                   , conduit                 >= 1.3
-                   , conduit-extra
                    , nonce                   >= 1.0.2     && < 1.1
-                   , unliftio-core
+                   , persistent              >= 2.8
+                   , random                  >= 1.0.0.2
+                   , safe
+                   , shakespeare
+                   , template-haskell
+                   , text                    >= 0.7
+                   , time
+                   , transformers            >= 0.2.2
                    , unliftio
+                   , unliftio-core
+                   , unordered-containers
+                   , wai                     >= 1.4
+                   , yesod-core              >= 1.6       && < 1.7
+                   , yesod-form              >= 1.6       && < 1.8
+                   , yesod-persistent        >= 1.6
 
     if flag(network-uri)
       build-depends: network-uri >= 2.6
-    else
-      build-depends: network < 2.6
 
     exposed-modules: Yesod.Auth
                      Yesod.Auth.BrowserId

yesod-bin/AddHandler.hs

@@ -9,11 +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, 0, 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)
@@ -60,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): "
@@ -82,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 $
@@ -236,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,45 @@
+# 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
+
+## 1.6.0.3
+
+* Support Cabal 2.2 [#1151](https://github.com/yesodweb/yesod/issues/1511)
+
+## 1.6.0.2
+
+* Fix broken support for older http-reverse-proxy
+
+## 1.6.0.1
+
+* Support for http-reverse-proxy 0.6
+
 ## 1.6.0
 
 * Upgrade to conduit 1.3.0

yesod-bin/Devel.hs

@@ -18,7 +18,6 @@ import           Control.Monad                         (forever, unless, void,
 import Data.ByteString (ByteString, isInfixOf)
 import qualified Data.ByteString.Lazy                  as LB
 import           Conduit
-import           Data.Default.Class                    (def)
 import           Data.FileEmbed                        (embedFile)
 import qualified Data.Map                              as Map
 import           Data.Maybe                            (isJust)
@@ -29,7 +28,14 @@ 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
 import qualified Distribution.PackageDescription.Parse as D
+#endif
 import qualified Distribution.Simple.Utils             as D
 import qualified Distribution.Verbosity                as D
 import           Network.HTTP.Client                   (newManager)
@@ -38,7 +44,13 @@ import           Network.HTTP.Client                   (managerSetProxy,
 import           Network.HTTP.Client.TLS               (tlsManagerSettings)
 import           Network.HTTP.ReverseProxy             (ProxyDest (ProxyDest),
                                                         waiProxyToSettings,
-                                                        wpsOnExc, wpsTimeout)
+                                                        wpsOnExc, wpsTimeout,
+#if MIN_VERSION_http_reverse_proxy(0, 6, 0)
+                                                        defaultWaiProxySettings
+#else
+                                                        def
+#endif
+                                                        )
 import qualified Network.HTTP.ReverseProxy             as ReverseProxy
 import           Network.HTTP.Types                    (status200, status503)
 import qualified Network.Socket
@@ -47,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
@@ -117,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
@@ -126,7 +139,7 @@ reverseProxy :: DevelOpts -> TVar Int -> IO ()
 reverseProxy opts appPortVar = do
     manager <- newManager $ managerSetProxy noProxy tlsManagerSettings
     let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")]
-        sayV = when (verbose opts) . sayString    
+        sayV = when (verbose opts) . sayString
     let onExc _ req
             | maybe False (("application/json" `elem`) . parseHttpAccept)
                 (lookup "accept" $ requestHeaders req) =
@@ -147,7 +160,11 @@ reverseProxy opts appPortVar = do
                     return $
                         ReverseProxy.WPRProxyDest
                         $ ProxyDest "127.0.0.1" appPort)
+#if MIN_VERSION_http_reverse_proxy(0, 6, 0)
+                defaultWaiProxySettings
+#else
                 def
+#endif
                     { wpsOnExc = \e req f -> onExc e req >>= f
                     , wpsTimeout =
                         if proxyTimeout opts == 0
@@ -157,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")
@@ -273,7 +292,9 @@ devel opts passThroughArgs = do
 
     -- Find out the name of our package, needed for the upcoming Stack
     -- commands
-#if MIN_VERSION_Cabal(1, 20, 0)
+#if MIN_VERSION_Cabal(3, 0, 0)
+    cabal  <- D.tryFindPackageDesc D.silent "."
+#elif MIN_VERSION_Cabal(1, 20, 0)
     cabal  <- D.tryFindPackageDesc "."
 #else
     cabal  <- D.findPackageDesc "."
@@ -330,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
@@ -103,7 +104,7 @@ to jump through the hoops implied above.
 
 One important note: I highly recommend putting _all_ of the logic in
 your library, and then providing a `develMain :: IO ()` function which
-yoru `app/devel.hs` script reexports as `main`. I've found this to
+your `app/devel.hs` script reexports as `main`. I've found this to
 greatly simplify things overall, since you can ensure all of your
 dependencies are specified correctly in your `.cabal` file. Also, I
 recommend using `PackageImports` in that file, as the example app

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
+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,56 +19,49 @@ extra-source-files:
   *.pem
 
 executable             yesod
+    default-language: Haskell2010
     if os(windows)
         cpp-options:     -DWINDOWS
     if os(openbsd)
         ld-options:      -Wl,-zwxneeded
 
-    build-depends:     base               >= 4.3          && < 5
+    build-depends:     base               >= 4.10         && < 5
-                     , parsec             >= 2.1          && < 4
-                     , text               >= 0.11
-                     , shakespeare        >= 2.0
-                     , bytestring         >= 0.9.1.4
-                     , time               >= 1.1.4
-                     , template-haskell
-                     , directory          >= 1.2.1
                      , Cabal              >= 1.18
-                     , unix-compat        >= 0.2
+                     , bytestring         >= 0.9.1.4
-                     , containers         >= 0.2
-                     , attoparsec         >= 0.10
-                     , http-types         >= 0.7
-                     , blaze-builder      >= 0.2.1.4      && < 0.5
-                     , filepath           >= 1.1
-                     , process
-                     , zlib               >= 0.5
-                     , tar                >= 0.4          && < 0.6
-                     , unordered-containers
-                     , yaml               >= 0.8          && < 0.9
-                     , optparse-applicative >= 0.11
-                     , fsnotify           >= 0.0          && < 0.3
-                     , split              >= 0.2          && < 0.3
-                     , file-embed
                      , conduit            >= 1.3
                      , conduit-extra      >= 1.3
-                     , resourcet          >= 1.2
+                     , containers         >= 0.2
-                     , base64-bytestring
+                     , data-default-class
-                     , http-reverse-proxy >= 0.4
+                     , directory          >= 1.2.1
-                     , network            >= 2.5
+                     , file-embed
-                     , http-client-tls
+                     , filepath           >= 1.1
+                     , fsnotify
                      , http-client        >= 0.4.7
+                     , http-client-tls
+                     , http-reverse-proxy >= 0.4
+                     , http-types         >= 0.7
+                     , network            >= 2.5
+                     , optparse-applicative >= 0.11
+                     , process
                      , project-template   >= 0.1.1
-                     , unliftio
                      , say
+                     , split              >= 0.2          && < 0.3
                      , stm
+                     , streaming-commons
+                     , tar                >= 0.4          && < 0.6
+                     , text               >= 0.11
+                     , time               >= 1.1.4
                      , transformers
                      , transformers-compat
-                     , warp               >= 1.3.7.5
+                     , unliftio
+                     , unordered-containers
                      , wai                >= 2.0
                      , wai-extra
-                     , data-default-class
+                     , warp               >= 1.3.7.5
-                     , streaming-commons
                      , warp-tls           >= 3.0.1
-                     , unliftio
+                     , yaml               >= 0.8          && < 0.12
+                     , zlib               >= 0.5
+                     , aeson
 
     ghc-options:       -Wall -threaded -rtsopts
     main-is:           main.hs

yesod-core/ChangeLog.md

@@ -1,3 +1,213 @@
+# 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
+
+## 1.6.18
+
+* Add functions for setting description and OG meta [#1663](https://github.com/yesodweb/yesod/pull/1663)
+
+* Use `DeriveLift` to implement the `Lift` instances for `ResourceTree`,
+  `Resource`, `Piece`, and `Dispatch`. Among other benefits, this provides
+  implementations of `liftTyped` on `template-haskell-2.16` (GHC 8.10) or
+  later. [#1664](https://github.com/yesodweb/yesod/pull/1664)
+
+## 1.6.17.3
+
+* Support for `unliftio-core` 0.2
+
+## 1.6.17.2
+
+* Support template-haskell 2.16, build with GHC 8.10 [#1657](https://github.com/yesodweb/yesod/pull/1657)
+
+## 1.6.17.1
+
+* Remove unnecessary deriving of Typeable
+
+## 1.6.17
+
+* Adds `contentTypeIsJson` [#1646](https://github.com/yesodweb/yesod/pull/1646)
+
+## 1.6.16.1
+
+* Compiles with GHC 8.8.1
+
+## 1.6.16
+
+* Add `jsAttributesHandler` to run arbitrary Handler code before building the
+  attributes map for the script tag generated by `widgetFile` [#1622](https://github.com/yesodweb/yesod/pull/1622)
+
+## 1.6.15
+
+* Move `redirectToPost` JavaScript form submission from HTML element to
+  `<script>` tag for CSP reasons [#1620](https://github.com/yesodweb/yesod/pull/1620)
+
+## 1.6.14
+
+* Introduce `JSONResponse`. [issue #1481](https://github.com/yesodweb/yesod/issues/1481) and [PR #1592](https://github.com/yesodweb/yesod/pull/1592)
+
+## 1.6.13
+
+* Introduce `maxContentLengthIO`. [issue #1588](https://github.com/yesodweb/yesod/issues/1588) and [PR #1589](https://github.com/yesodweb/yesod/pull/1589)
+
+## 1.6.12
+
+* Use at most one valid session cookie per request [#1581](https://github.com/yesodweb/yesod/pull/1581)
+
+## 1.6.11
+
+* Deprecate insecure JSON parsing functions [#1576](https://github.com/yesodweb/yesod/pull/1576)
+
+## 1.6.10.1
+
+* Fix test suite compilation for [commercialhaskell/stackage#4319](https://github.com/commercialhaskell/stackage/issues/4319)
+
+## 1.6.10
+
+* Adds functions to get and set values in the per-request caches. [#1573](https://github.com/yesodweb/yesod/pull/1573)
+
+## 1.6.9
+
+* Add `sendResponseNoContent` [#1565](https://github.com/yesodweb/yesod/pull/1565)
+
+## 1.6.8.1
+
+* Add missing test file to tarball [#1563](https://github.com/yesodweb/yesod/issues/1563)
+
+## 1.6.8
+* In the route syntax, allow trailing backslashes to indicate line
+    continuation. [#1558](https://github.com/yesodweb/yesod/pull/1558)
+
+## 1.6.7
+
+* If no matches are found, `selectRep` chooses first representation regardless
+    of the presence or absence of a `Content-Type` header in the request
+    [#1540](https://github.com/yesodweb/yesod/pull/1540)
+* Sets the `X-XSS-Protection` header to `1; mode=block` [#1550](https://github.com/yesodweb/yesod/pull/1550)
+* Add `PrimMonad` instances for `HandlerFor` and `WidgetFor` [from
+  StackOverflow](https://stackoverflow.com/q/52692508/369198)
+
+## 1.6.6
+
+* `defaultErrorHandler` handles text/plain requests [#1522](https://github.com/yesodweb/yesod/pull/1520)
+
+## 1.6.5
+
+* Add `fileSourceByteString` [#1503](https://github.com/yesodweb/yesod/pull/1503)
+
+## 1.6.4
+
+* Add `addContentDispositionFileName` [#1504](https://github.com/yesodweb/yesod/pull/1504)
+
+## 1.6.3
+
+* Add missing export for `SubHandlerFor`
+
 ## 1.6.2
 
 * Derive a `Show` instance for `ResourceTree` and `FlatResource` [#1492](https://github.com/yesodweb/yesod/pull/1492)

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

@@ -16,13 +16,12 @@ import Yesod.Core.Types
 import Control.Monad.Logger (MonadLogger)
 import Control.Monad.Trans.Resource (MonadResource)
 import Control.Monad.Trans.Class (lift)
-#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid (Monoid)
-#endif
 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  )
@@ -79,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)
@@ -107,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,8 +1,9 @@
-{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TemplateHaskell     #-}
-{-# LANGUAGE CPP               #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Yesod.Core.Class.Yesod where
 
 import           Yesod.Core.Content
@@ -14,9 +15,6 @@ import           Data.ByteString.Builder            (Builder)
 import           Data.Text.Encoding                 (encodeUtf8Builder)
 import           Control.Arrow                      ((***), second)
 import           Control.Exception                  (bracket)
-#if __GLASGOW_HASKELL__ < 710
-import           Control.Applicative                ((<$>))
-#endif
 import           Control.Monad                      (forM, when, void)
 import           Control.Monad.IO.Class             (MonadIO (liftIO))
 import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelOther),
@@ -27,6 +25,7 @@ import qualified Data.ByteString.Lazy               as L
 import Data.Aeson (object, (.=))
 import           Data.List                          (foldl', nub)
 import qualified Data.Map                           as Map
+import           Data.Maybe                         (catMaybes)
 import           Data.Monoid
 import           Data.Text                          (Text)
 import qualified Data.Text                          as T
@@ -55,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.
@@ -73,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'.
@@ -90,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
@@ -198,6 +211,7 @@ class RenderRoute site => Yesod site where
     addStaticContent _ _ _ = return Nothing
 
     -- | Maximum allowed length of the request body, in bytes.
+    -- This method may be ignored if 'maximumContentLengthIO' is overridden.
     --
     -- If @Nothing@, no maximum is applied.
     --
@@ -205,6 +219,18 @@ class RenderRoute site => Yesod site where
     maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64
     maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes
 
+    -- | Maximum allowed length of the request body, in bytes. This is similar
+    -- to 'maximumContentLength', but the result lives in @IO@. This allows
+    -- you to dynamically change the maximum file size based on some external
+    -- source like a database or an @IORef@.
+    --
+    -- The default implementation uses 'maximumContentLength'. Future version of yesod will
+    -- remove 'maximumContentLength' and use this method exclusively.
+    --
+    -- @since 1.6.13
+    maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)
+    maximumContentLengthIO a b = pure $ maximumContentLength a b
+
     -- | Creates a @Logger@ to use for log messages.
     --
     -- Note that a common technique (endorsed by the scaffolding) is to create
@@ -239,6 +265,16 @@ class RenderRoute site => Yesod site where
     jsAttributes :: site -> [(Text, Text)]
     jsAttributes _ = []
 
+    -- | Same as @jsAttributes@ but allows you to run arbitrary Handler code
+    --
+    -- This is useful if you need to add a randomised nonce value to the script
+    -- tag generated by @widgetFile@. If this function is overridden then
+    -- @jsAttributes@ is ignored.
+    --
+    -- @since 1.6.16
+    jsAttributesHandler :: HandlerFor site [(Text, Text)]
+    jsAttributesHandler = jsAttributes <$> getYesod
+
     -- | Create a session backend. Returning 'Nothing' disables
     -- sessions. If you'd like to change the way that the session
     -- cookies are created, take a look at
@@ -341,12 +377,14 @@ defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool
 defaultShouldLogIO _ level = return $ level >= LevelInfo
 
 -- | Default implementation of 'yesodMiddleware'. Adds the response header
--- \"Vary: Accept, Accept-Language\" and performs authorization checks.
+-- \"Vary: Accept, Accept-Language\", \"X-XSS-Protection: 1; mode=block\", and
+-- performs authorization checks.
 --
 -- Since 1.2.0
 defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
 defaultYesodMiddleware handler = do
     addHeader "Vary" "Accept, Accept-Language"
+    addHeader "X-XSS-Protection" "1; mode=block"
     authorizationCheck
     handler
 
@@ -508,15 +546,18 @@ defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddlew
 widgetToPageContent :: Yesod site
                     => WidgetFor site ()
                     -> HandlerFor site (PageContent (Route site))
-widgetToPageContent w = HandlerFor $ \hd -> do
+widgetToPageContent w = do
+ jsAttrs <- jsAttributesHandler
+ HandlerFor $ \hd -> do
   master <- unHandlerFor getYesod hd
   ref <- newIORef mempty
   unWidgetFor w WidgetData
     { wdRef = ref
     , wdHandler = hd
     }
-  GWData (Body body) (Last mTitle) 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'
 
@@ -552,7 +593,7 @@ widgetToPageContent w = HandlerFor $ \hd -> do
                 ^{mkScriptTag s}
             $maybe j <- jscript
                 $maybe s <- jsLoc
-                    <script src="#{s}" *{jsAttributes master}>
+                    <script src="#{s}" *{jsAttrs}>
                 $nothing
                     <script>^{jelper j}
         |]
@@ -586,7 +627,7 @@ widgetToPageContent w = HandlerFor $ \hd -> do
             ^{regularScriptLoad}
         |]
 
-    return $ PageContent title headAll $
+    return $ PageContent title description headAll $
         case jsLoader master of
             BottomOfBody -> bodyScript
             _ -> body
@@ -615,6 +656,7 @@ defaultErrorHandler NotFound = selectRep $ do
         let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
         defaultMessageWidget "Not Found" [hamlet|<p>#{path'}|]
     provideRep $ return $ object ["message" .= ("Not Found" :: Text)]
+    provideRep $ return ("Not Found" :: Text)
 
 -- For API requests.
 -- For a user with a browser,
@@ -638,6 +680,7 @@ defaultErrorHandler NotAuthenticated = selectRep $ do
         let apair u = ["authentication_url" .= rend u]
             content = maybe [] apair (authRoute site)
         return $ object $ ("message" .= ("Not logged in"::Text)):content
+    provideRep $ return ("Not logged in" :: Text)
 
 defaultErrorHandler (PermissionDenied msg) = selectRep $ do
     provideRep $ defaultLayout $ defaultMessageWidget
@@ -645,6 +688,7 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do
         [hamlet|<p>#{msg}|]
     provideRep $
         return $ object ["message" .= ("Permission Denied. " <> msg)]
+    provideRep $ return $ "Permission Denied. " <> msg
 
 defaultErrorHandler (InvalidArgs ia) = selectRep $ do
     provideRep $ defaultLayout $ defaultMessageWidget
@@ -655,6 +699,8 @@ defaultErrorHandler (InvalidArgs ia) = selectRep $ do
                     <li>#{msg}
         |]
     provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]
+    provideRep $ return ("Invalid Arguments: " <> T.intercalate " " ia)
+
 defaultErrorHandler (InternalError e) = do
     $logErrorS "yesod-core" e
     selectRep $ do
@@ -662,11 +708,14 @@ defaultErrorHandler (InternalError e) = do
             "Internal Server Error"
             [hamlet|<pre>#{e}|]
         provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]
+        provideRep $ return $ "Internal Server Error: " <> e
+
 defaultErrorHandler (BadMethod m) = selectRep $ do
     provideRep $ defaultLayout $ defaultMessageWidget
         "Method Not Supported"
         [hamlet|<p>Method <code>#{S8.unpack m}</code> not supported|]
     provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
+    provideRep $ return $ "Bad Method " <> TE.decodeUtf8With TEE.lenientDecode m
 
 asyncHelper :: (url -> [x] -> Text)
          -> [Script url]
@@ -814,6 +863,12 @@ clientSessionBackend key getCachedDate =
     sbLoadSession = loadClientSession key getCachedDate "_SESSION"
   }
 
+justSingleton :: a -> [Maybe a] -> a
+justSingleton d = just . catMaybes
+  where
+    just [s] = s
+    just _   = d
+
 loadClientSession :: CS.Key
                   -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
                   -> S8.ByteString -- ^ session name
@@ -824,11 +879,11 @@ loadClientSession key getCachedDate sessionName req = load
     load = do
       date <- getCachedDate
       return (sess date, save date)
-    sess date = Map.unions $ do
+    sess date = justSingleton Map.empty $ do
       raw <- [v | (k, v) <- W.requestHeaders req, k == "Cookie"]
       val <- [v | (k, v) <- parseCookies raw, k == sessionName]
       let host = "" -- fixme, properly lock sessions to client address
-      maybe [] return $ decodeClientSession key date host val
+      return $ decodeClientSession key date host val
     save date sess' = do
       -- We should never cache the IV!  Be careful!
       iv <- liftIO CS.randomIV

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

@@ -4,7 +4,6 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
 module Yesod.Core.Content
     ( -- * Content
       Content (..)
@@ -56,9 +55,6 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8Builder)
 import qualified Data.Text.Lazy as TL
 import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8)
-#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid (mempty)
-#endif
 import Text.Hamlet (Html)
 import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
 import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput)
@@ -68,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)
@@ -107,10 +104,14 @@ instance ToContent Html where
     toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
 instance ToContent () where
     toContent () = toContent B.empty
+instance ToContent Void where
+    toContent = absurd
 instance ToContent (ContentType, Content) where
     toContent = snd
 instance ToContent TypedContent where
     toContent (TypedContent _ c) = c
+instance ToContent (JSONResponse a) where
+    toContent (JSONResponse a) = toContent $ J.toEncoding a
 
 instance ToContent Css where
     toContent = toContent . renderCss
@@ -164,6 +165,8 @@ deriving instance ToContent RepJson
 instance HasContentType RepPlain where
     getContentType _ = typePlain
 deriving instance ToContent RepPlain
+instance HasContentType (JSONResponse a) where
+    getContentType _ = typeJson
 
 instance HasContentType RepXml where
     getContentType _ = typeXml
@@ -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
@@ -296,6 +301,8 @@ instance ToTypedContent [Char] where
     toTypedContent = toTypedContent . pack
 instance ToTypedContent Text where
     toTypedContent t = TypedContent typePlain (toContent t)
+instance ToTypedContent (JSONResponse a) where
+    toTypedContent c = TypedContent typeJson (toContent c)
 instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
     toTypedContent (DontFullyEvaluate a) =
         let TypedContent ct c = toTypedContent a

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

@@ -3,7 +3,6 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE CPP #-}
 module Yesod.Core.Dispatch
     ( -- * Quasi-quoted routing
       parseRoutes
@@ -11,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 (..)
@@ -47,10 +57,8 @@ import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
 
+import Data.Bits ((.|.), finiteBitSize, shiftL)
 import Data.Text (Text)
-#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid (mappend)
-#endif
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Char8 as S8
@@ -61,9 +69,9 @@ import Yesod.Core.Types
 import Yesod.Core.Class.Yesod
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
-import Safe (readMay)
+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)
 
@@ -96,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
@@ -176,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.
 --
@@ -243,7 +274,7 @@ warpEnv site = do
     case lookup "PORT" env of
         Nothing -> error "warpEnv: no PORT environment variable found"
         Just portS ->
-            case readMay portS of
+            case readMaybe portS of
                 Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS
                 Just port -> warp port site
 

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP                        #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE ConstraintKinds            #-}
 {-# LANGUAGE FlexibleInstances          #-}
@@ -9,8 +8,8 @@
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE RankNTypes                 #-}
-{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TemplateHaskell            #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -47,6 +46,7 @@ module Yesod.Core.Handler
     , fileName
     , fileContentType
     , fileSource
+    , fileSourceByteString
     , fileMove
       -- *** Convenience functions
     , languages
@@ -91,7 +91,8 @@ module Yesod.Core.Handler
     , permissionDeniedI
     , invalidArgs
     , invalidArgsI
-      -- ** Short-circuit responses.
+      -- ** Short-circuit responses
+      -- $rollbackWarning
     , sendFile
     , sendFilePart
     , sendResponse
@@ -99,6 +100,7 @@ module Yesod.Core.Handler
       -- ** Type specific response with custom status
     , sendStatusJSON
     , sendResponseCreated
+    , sendResponseNoContent
     , sendWaiResponse
     , sendWaiApplication
     , sendRawResponse
@@ -118,6 +120,7 @@ module Yesod.Core.Handler
     , setHeader
     , replaceOrAddHeader
     , setLanguage
+    , addContentDispositionFileName
       -- ** Content caching and expiration
     , cacheSeconds
     , neverExpires
@@ -148,6 +151,7 @@ module Yesod.Core.Handler
     , setMessageI
     , getMessage
       -- * Subsites
+    , SubHandlerFor
     , getSubYesod
     , getRouteToParent
     , getSubCurrentRoute
@@ -165,7 +169,11 @@ module Yesod.Core.Handler
     , getMessageRender
       -- * Per-request caching
     , cached
+    , cacheGet
+    , cacheSet
     , cachedBy
+    , cacheByGet
+    , cacheBySet
       -- * AJAX CSRF protection
 
       -- $ajaxCSRFOverview
@@ -192,10 +200,6 @@ import           Yesod.Core.Internal.Request   (langKey, mkFileInfoFile,
                                                 mkFileInfoLBS, mkFileInfoSource)
 
 
-#if __GLASGOW_HASKELL__ < 710
-import           Control.Applicative           ((<$>))
-import           Data.Monoid                   (mempty, mappend)
-#endif
 import           Control.Applicative           ((<|>))
 import qualified Data.CaseInsensitive          as CI
 import           Control.Exception             (evaluate, SomeException, throwIO)
@@ -225,7 +229,7 @@ import qualified Data.ByteString.Lazy          as L
 import qualified Data.Map                      as Map
 import qualified Data.HashMap.Strict           as HM
 
-import           Data.Byteable                 (constEqBytes)
+import           Data.ByteArray                (constEq)
 
 import           Control.Arrow                 ((***))
 import qualified Data.ByteString.Char8         as S8
@@ -241,23 +245,24 @@ import           Text.Blaze.Html               (preEscapedToHtml, toHtml)
 import qualified Data.IORef                    as I
 import           Data.Maybe                    (listToMaybe, mapMaybe)
 import           Data.Typeable                 (Typeable)
+import           Data.Kind                     (Type)
 import           Web.PathPieces                (PathPiece(..))
 import           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
 import           Yesod.Routes.Class            (Route)
 import           Data.ByteString.Builder (Builder)
-import           Safe (headMay)
 import           Data.CaseInsensitive (CI, original)
 import qualified Data.Conduit.List as CL
 import           Control.Monad.Trans.Resource  (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)
 import qualified System.PosixCompat.Files as PC
+import           Conduit ((.|), runConduit, sinkLazy)
 import           Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void)
 import qualified Yesod.Core.TypeCache as Cache
 import qualified Data.Word8 as W8
 import qualified Data.Foldable as Fold
 import           Control.Monad.Logger (MonadLogger, logWarnS)
 
-type HandlerT site (m :: * -> *) = HandlerFor site
+type HandlerT site (m :: Type -> Type) = HandlerFor site
 {-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
 
 get :: MonadHandler m => m GHState
@@ -366,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:
 --
 -- @
@@ -377,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 =
@@ -425,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
@@ -602,7 +607,21 @@ setMessageI = addMessageI ""
 -- | Gets just the last message in the user's session,
 -- discards the rest and the status
 getMessage :: MonadHandler m => m (Maybe Html)
-getMessage = fmap (fmap snd . headMay) getMessages
+getMessage = fmap (fmap snd . listToMaybe) getMessages
+
+-- $rollbackWarning
+--
+-- Note that since short-circuiting is implemented by using exceptions,
+-- using e.g. 'sendStatusJSON' inside a runDB block
+-- will result in the database actions getting rolled back:
+--
+-- @
+-- runDB $ do
+--   userId <- insert $ User "username" "email@example.com"
+--   postId <- insert $ BlogPost "title" "hi there!"
+--     /The previous two inserts will be rolled back./
+--   sendStatusJSON Status.status200 ()
+-- @
 
 -- | Bypass remaining handler code and output the given file.
 --
@@ -650,6 +669,12 @@ sendResponseCreated url = do
     r <- getUrlRender
     handlerError $ HCCreated $ r url
 
+-- | Bypass remaining handler code and output no content with a 204 status code.
+--
+-- @since 1.6.9
+sendResponseNoContent :: MonadHandler m => m a
+sendResponseNoContent = sendWaiResponse $ W.responseBuilder H.status204 [] mempty
+
 -- | Send a 'W.Response'. Please note: this function is rarely
 -- necessary, and will /disregard/ any changes to response headers and session
 -- that you have already specified. This function short-circuits. It should be
@@ -779,6 +804,26 @@ deleteCookie a = addHeaderInternal . DeleteCookie (encodeUtf8 a) . encodeUtf8
 setLanguage :: MonadHandler m => Text -> m ()
 setLanguage = setSession langKey
 
+-- | Set attachment file name.
+--
+-- Allows Unicode characters by encoding to UTF-8.
+-- Some modurn browser parse UTF-8 characters with out encoding setting.
+-- But, for example IE9 can't parse UTF-8 characters.
+-- This function use
+-- <https://tools.ietf.org/html/rfc6266 RFC 6266>(<https://tools.ietf.org/html/rfc5987 RFC 5987>)
+--
+-- @since 1.6.4
+addContentDispositionFileName :: MonadHandler m => T.Text -> m ()
+addContentDispositionFileName fileName
+    = addHeader "Content-Disposition" $ rfc6266Utf8FileName fileName
+
+-- | <https://tools.ietf.org/html/rfc6266 RFC 6266> Unicode attachment filename.
+--
+-- > rfc6266Utf8FileName (Data.Text.pack "€")
+-- "attachment; filename*=UTF-8''%E2%82%AC"
+rfc6266Utf8FileName :: T.Text -> T.Text
+rfc6266Utf8FileName fileName = "attachment; filename*=UTF-8''" `mappend` decodeUtf8 (H.urlEncode True (encodeUtf8 fileName))
+
 -- | Set an arbitrary response header.
 --
 -- Note that, while the data type used here is 'Text', you must provide only
@@ -993,7 +1038,7 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map k
 -- > redirect (NewsfeedR :#: storyId)
 --
 -- @since 1.2.9.
-data Fragment a b = a :#: b deriving (Show, Typeable)
+data Fragment a b = a :#: b deriving Show
 
 instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where
   toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a
@@ -1040,13 +1085,15 @@ $doctype 5
 <html>
     <head>
         <title>Redirecting...
-    <body onload="document.getElementById('form').submit()">
+    <body>
         <form id="form" method="post" action=#{urlText}>
             $maybe token <- reqToken req
                 <input type=hidden name=#{defaultCsrfParamName} value=#{token}>
             <noscript>
                 <p>Javascript has been disabled; please click on the button below to be redirected.
             <input type="submit" value="Continue">
+        <script>
+          window.onload = function() { document.getElementById('form').submit(); };
 |] >>= sendResponse
 
 -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
@@ -1109,6 +1156,27 @@ cached action = do
           put $ gs { ghsCache = merged }
           return res
 
+-- | Retrieves a value from the cache used by 'cached'.
+--
+-- @since 1.6.10
+cacheGet :: (MonadHandler m, Typeable a)
+         => m (Maybe a)
+cacheGet = do
+  cache <- ghsCache <$> get
+  pure $ Cache.cacheGet cache
+
+-- | Sets a value in the cache used by 'cached'.
+--
+-- @since 1.6.10
+cacheSet :: (MonadHandler m, Typeable a)
+         => a
+         -> m ()
+cacheSet value = do
+  gs <- get
+  let cache = ghsCache gs
+      newCache = Cache.cacheSet value cache
+  put $ gs { ghsCache = newCache }
+
 -- | a per-request cache. just like 'cached'.
 -- 'cached' can only cache a single value per type.
 -- 'cachedBy' stores multiple values per type by usage of a ByteString key
@@ -1131,15 +1199,38 @@ cachedBy k action = do
           put $ gs { ghsCacheBy = merged }
           return res
 
+-- | Retrieves a value from the cache used by 'cachedBy'.
+--
+-- @since 1.6.10
+cacheByGet :: (MonadHandler m, Typeable a)
+           => S.ByteString
+           -> m (Maybe a)
+cacheByGet key = do
+  cache <- ghsCacheBy <$> get
+  pure $ Cache.cacheByGet key cache
+
+-- | Sets a value in the cache used by 'cachedBy'.
+--
+-- @since 1.6.10
+cacheBySet :: (MonadHandler m, Typeable a)
+           => S.ByteString
+           -> a
+           -> m ()
+cacheBySet key value = do
+  gs <- get
+  let cache = ghsCacheBy gs
+      newCache = Cache.cacheBySet key value cache
+  put $ gs { ghsCacheBy = newCache }
+
 -- | Get the list of supported languages supplied by the user.
 --
 -- Languages are determined based on the following (in descending order
 -- of preference):
 --
--- * The _LANG user session variable.
---
 -- * The _LANG get parameter.
 --
+-- * The _LANG user session variable.
+--
 -- * The _LANG cookie.
 --
 -- * Accept-Language HTTP header.
@@ -1148,11 +1239,12 @@ cachedBy k action = 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)
@@ -1271,15 +1363,9 @@ selectRep w = do
         [] ->
             case reps of
                 [] -> sendResponseStatus H.status500 ("No reps provided to selectRep" :: Text)
-                rep:_ ->
+                rep:_ -> returnRep rep
-                  if null cts
-                    then returnRep rep
-                    else sendResponseStatus H.status406 explainUnaccepted
         rep:_ -> returnRep rep
   where
-    explainUnaccepted :: Text
-    explainUnaccepted = "no match found for accept header"
-
     returnRep (ProvidedRep ct mcontent) = fmap (TypedContent ct) mcontent
 
     reps = appEndo (Writer.execWriter w) []
@@ -1298,7 +1384,7 @@ selectRep w = do
     tryAccept ct =
         if subType == "*"
           then if mainType == "*"
-                 then headMay reps
+                 then listToMaybe reps
                  else Map.lookup mainType mainTypeMap
           else lookupAccept ct
         where
@@ -1359,6 +1445,17 @@ rawRequestBody = do
 fileSource :: MonadResource m => FileInfo -> ConduitT () S.ByteString m ()
 fileSource = transPipe liftResourceT . fileSourceRaw
 
+-- | Extract a strict `ByteString` body from a `FileInfo`.
+--
+-- This function will block while reading the file.
+--
+-- > do
+-- >     fileByteString <- fileSourceByteString fileInfo
+--
+-- @since 1.6.5
+fileSourceByteString :: MonadResource m => FileInfo -> m S.ByteString
+fileSourceByteString fileInfo = runConduit (L.toStrict <$> (fileSource fileInfo .| sinkLazy))
+
 -- | Provide a pure value for the response body.
 --
 -- > respond ct = return . TypedContent ct . toContent
@@ -1369,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.
@@ -1381,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
 
@@ -1570,8 +1667,8 @@ checkCsrfHeaderOrParam headerName paramName = do
     permissionDenied errorMessage
 
 validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool
--- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.
+-- It's important to use constant-time comparison (constEq) in order to avoid timing attacks.
-validCsrf (Just token) (Just param) = encodeUtf8 token `constEqBytes` param
+validCsrf (Just token) (Just param) = encodeUtf8 token `constEq` param
 validCsrf Nothing            _param = True
 validCsrf (Just _token)     Nothing = False
 

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

@@ -1,9 +1,6 @@
 {-# LANGUAGE TypeFamilies, PatternGuards, CPP #-}
 module Yesod.Core.Internal.LiteApp where
 
-#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid
-#endif
 #if !(MIN_VERSION_base(4,11,0))
 import Data.Semigroup (Semigroup(..))
 #endif

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

@@ -71,7 +71,7 @@ tooLargeResponse maxLen bodyLen = W.responseLBS
         , (LS8.pack (show maxLen))
         , " bytes; your request body was "
         , (LS8.pack (show bodyLen))
-        , " bytes. If you're the developer of this site, you can configure the maximum length with the `maximumContentLength` function on the Yesod typeclass."
+        , " bytes. If you're the developer of this site, you can configure the maximum length with the `maximumContentLength` or `maximumContentLengthIO` function on the Yesod typeclass."
         ])
 
 parseWaiRequest :: W.Request
@@ -129,7 +129,7 @@ parseWaiRequest env session useToken mmaxBodySize =
                 -- Already have a token, use it.
                 Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs
                 -- Don't have a token, get a random generator and make a new one.
-                Nothing -> Right $ fmap Just . randomString 10
+                Nothing -> Right $ fmap Just . randomString 40
         | otherwise = Left Nothing
 
 textQueryString :: W.Request -> [(Text, Text)]

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

@@ -1,18 +1,28 @@
-{-# LANGUAGE CPP               #-}
+{-# 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  #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-module Yesod.Core.Internal.Run where
+module Yesod.Core.Internal.Run
+  ( toErrorHandler
+  , errFromShow
+  , basicRunHandler
+  , handleError
+  , handleContents
+  , evalFallback
+  , runHandler
+  , safeEh
+  , runFakeHandler
+  , yesodRunner
+  , yesodRender
+  , resolveApproot
+  )
+  where
 
-
+import qualified Control.Exception as EUnsafe
-#if __GLASGOW_HASKELL__ < 710
-import           Data.Monoid                  (Monoid, mempty)
-import           Control.Applicative          ((<$>))
-#endif
 import Yesod.Core.Internal.Response
 import           Data.ByteString.Builder      (toLazyByteString)
 import qualified Data.ByteString.Lazy         as BL
@@ -44,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
@@ -76,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)
@@ -177,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
@@ -197,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
@@ -221,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
@@ -262,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
@@ -287,10 +303,8 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
           , vault          = mempty
           , requestBodyLength = KnownLength 0
           , requestHeaderRange = Nothing
-#if MIN_VERSION_wai(3,2,0)
           , requestHeaderReferer = Nothing
           , requestHeaderUserAgent = Nothing
-#endif
           }
       fakeRequest =
         YesodRequest
@@ -305,48 +319,51 @@ 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)
             -> Application
-yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
+yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
-  | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse (tooLargeResponse maxLen len)
+  mmaxLen <- maximumContentLengthIO yreSite route
-  | otherwise = do
+  case (mmaxLen, requestBodyLength req) of
-    let dontSaveSession _ = return []
+    (Just maxLen, KnownLength len) | maxLen < len -> sendResponse (tooLargeResponse maxLen len)
-    (session, saveSession) <- liftIO $
+    _ -> do
-        maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend
+      let dontSaveSession _ = return []
-    maxExpires <- yreGetMaxExpires
+      (session, saveSession) <- liftIO $
-    let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
+          maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend
-    let yreq =
+      maxExpires <- yreGetMaxExpires
-            case mkYesodReq of
+      let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
-                Left yreq' -> yreq'
+      let yreq =
-                Right needGen -> needGen yreGen
+              case mkYesodReq of
-    let ra = resolveApproot yreSite req
+                  Left yreq' -> yreq'
-    let log' = messageLoggerSource yreSite yreLogger
+                  Right needGen -> needGen yreGen
-        -- We set up two environments: the first one has a "safe" error handler
+      let ra = resolveApproot yreSite req
-        -- which will never throw an exception. The second one uses the
+      let log' = messageLoggerSource yreSite yreLogger
-        -- user-provided errorHandler function. If that errorHandler function
+          -- We set up two environments: the first one has a "safe" error handler
-        -- errors out, it will use the safeEh below to recover.
+          -- which will never throw an exception. The second one uses the
-        rheSafe = RunHandlerEnv
+          -- user-provided errorHandler function. If that errorHandler function
-            { rheRender = yesodRender yreSite ra
+          -- errors out, it will use the safeEh below to recover.
-            , rheRoute = route
+          rheSafe = RunHandlerEnv
-            , rheRouteToMaster = id
+              { rheRender = yesodRender yreSite ra
-            , rheChild = yreSite
+              , rheRoute = route
-            , rheSite = yreSite
+              , rheRouteToMaster = id
-            , rheUpload = fileUpload yreSite
+              , rheChild = yreSite
-            , rheLog = log'
+              , rheSite = yreSite
-            , rheOnError = safeEh log'
+              , rheUpload = fileUpload yreSite
-            , rheMaxExpires = maxExpires
+              , rheLog = log'
-            }
+              , rheOnError = safeEh log'
-        rhe = rheSafe
+              , rheMaxExpires = maxExpires
-            { rheOnError = runHandler rheSafe . errorHandler
+              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite
-            }
+              }
+          rhe = rheSafe
+              { rheOnError = runHandler rheSafe . errorHandler
+              }
 
-    yesodWithInternalState yreSite route $ \is -> do
+      yesodWithInternalState yreSite route $ \is -> do
-        yreq' <- yreq
+          yreq' <- yreq
-        yar <- runInternalState (runHandler rhe handler yreq') is
+          yar <- runInternalState (runHandler rhe handler yreq') is
-        yarToResponse yar saveSession yreq' req is sendResponse
+          yarToResponse yar saveSession yreq' req is sendResponse
   where
     mmaxLen = maximumContentLength yreSite route
     handler = yesodMiddleware handler'

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

@@ -1,11 +1,48 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE CPP #-}
 {-# 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
@@ -17,15 +54,13 @@ import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
 import Data.List (foldl')
-#if __GLASGOW_HASKELL__ < 710
-import Control.Applicative ((<$>))
-#endif
 import Control.Monad (replicateM, void)
 import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)
 import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
 
 import 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
@@ -39,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. 
@@ -52,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
@@ -68,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
@@ -104,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
@@ -124,13 +204,22 @@ 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) -> 
-#if MIN_VERSION_template_haskell(2,10,0)
             foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
-#else
-            ClassP (mkName c) $ fmap nameToType rest
-#endif
           ) appCxt'
     mname <- lookupTypeName namestr
     arity <- case mname of
@@ -140,13 +229,8 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
                    case info of
                      TyConI dec ->
                        case dec of
-#if MIN_VERSION_template_haskell(2,11,0)
                          DataD _ _ vs _ _ _ -> length vs
                          NewtypeD _ _ vs _ _ _ -> length vs
-#else
-                         DataD _ _ vs _ _ -> length vs
-                         NewtypeD _ _ vs _ _ -> length vs
-#endif
                          TySynD _ vs _ -> length vs
                          _ -> 0
                      _ -> 0
@@ -154,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
@@ -173,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|]
@@ -209,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"
@@ -229,9 +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
-#if MIN_VERSION_template_haskell(2,11,0)
 instanceD = InstanceD Nothing
-#else
-instanceD = InstanceD
-#endif

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

@@ -10,11 +10,14 @@ module Yesod.Core.Json
     , provideJson
 
       -- * Convert to a JSON value
-    , parseJsonBody
     , parseCheckJsonBody
+    , parseInsecureJsonBody
+    , requireCheckJsonBody
+    , requireInsecureJsonBody
+      -- ** Deprecated JSON conversion
+    , parseJsonBody
     , parseJsonBody_
     , requireJsonBody
-    , requireCheckJsonBody
 
       -- * Produce JSON values
     , J.Value (..)
@@ -29,6 +32,9 @@ module Yesod.Core.Json
     , jsonOrRedirect
     , jsonEncodingOrRedirect
     , acceptsJson
+
+      -- * Checking if data is JSON
+    , contentTypeHeaderIsJson
     ) where
 
 import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)
@@ -92,49 +98,74 @@ returnJsonEncoding = return . J.toEncoding
 provideJson :: (Monad m, J.ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()
 provideJson = provideRep . return . J.toEncoding
 
+-- | Same as 'parseInsecureJsonBody'
+--
+-- @since 0.3.0
+parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
+parseJsonBody = parseInsecureJsonBody
+{-# DEPRECATED parseJsonBody "Use parseCheckJsonBody or parseInsecureJsonBody instead" #-}
+
+-- | Same as 'parseCheckJsonBody', but does not check that the mime type
+-- indicates JSON content.
+--
+-- Note: This function is vulnerable to CSRF attacks.
+--
+-- @since 1.6.11
+parseInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
+parseInsecureJsonBody = do
+    eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')
+    return $ case eValue of
+        Left e -> J.Error $ show e
+        Right value -> J.fromJSON value
+
 -- | Parse the request body to a data type as a JSON value.  The
 -- data type must support conversion from JSON via 'J.FromJSON'.
 -- If you want the raw JSON value, just ask for a @'J.Result'
 -- 'J.Value'@.
 --
+-- The MIME type must indicate JSON content. Requiring a JSON
+-- content-type helps secure your site against CSRF attacks
+-- (browsers will perform POST requests for form and text/plain
+-- content-types without doing a CORS check, and those content-types
+-- can easily contain valid JSON).
+--
 -- Note that this function will consume the request body. As such, calling it
 -- twice will result in a parse error on the second call, since the request
 -- body will no longer be available.
 --
 -- @since 0.3.0
-parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
-parseJsonBody = do
-    eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')
-    return $ case eValue of
-        Left e -> J.Error $ show e
-        Right value -> J.fromJSON value
-
--- | Same as 'parseJsonBody', but ensures that the mime type indicates
--- JSON content.
 parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
 parseCheckJsonBody = do
     mct <- lookupHeader "content-type"
-    case fmap (B8.takeWhile (/= ';')) mct of
+    case fmap contentTypeHeaderIsJson mct of
-        Just "application/json" -> parseJsonBody
+        Just True -> parseInsecureJsonBody
         _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct
 
--- | Same as 'parseJsonBody', but return an invalid args response on a parse
+-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
 -- error.
 parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
-parseJsonBody_ = requireJsonBody
+parseJsonBody_ = requireInsecureJsonBody
-{-# DEPRECATED parseJsonBody_ "Use requireJsonBody instead" #-}
+{-# DEPRECATED parseJsonBody_ "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}
 
--- | Same as 'parseJsonBody', but return an invalid args response on a parse
+-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
 -- error.
 requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a
-requireJsonBody = do
+requireJsonBody = requireInsecureJsonBody
-    ra <- parseJsonBody
+{-# DEPRECATED requireJsonBody "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}
+
+-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
+-- error.
+--
+-- @since 1.6.11
+requireInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m a
+requireInsecureJsonBody = do
+    ra <- parseInsecureJsonBody
     case ra of
         J.Error s -> invalidArgs [pack s]
         J.Success a -> return a
 
--- | Same as 'requireJsonBody', but ensures that the mime type
+-- | Same as 'parseCheckJsonBody', but return an invalid args response on a parse
--- indicates JSON content.
+-- error.
 requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a
 requireCheckJsonBody = do
     ra <- parseCheckJsonBody
@@ -190,3 +221,12 @@ acceptsJson =  (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
             .  listToMaybe
             .  reqAccept)
            `liftM` getRequest
+
+-- | Given the @Content-Type@ header, returns if it is JSON.
+--
+-- This function is currently a simple check for @application/json@, but in the future may check for
+-- alternative representations such as @<https://tools.ietf.org/html/rfc6839#section-3.1 xxx/yyy+json>@.
+--
+-- @since 1.6.17
+contentTypeHeaderIsJson :: B8.ByteString -> Bool
+contentTypeHeaderIsJson bs = B8.takeWhile (/= ';') bs == "application/json"

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

@@ -7,7 +7,7 @@
 -- Note that a TypeRep is unique to a module in a package, so types from different modules will not conflict if they have the same name.
 --
 -- used in 'Yesod.Core.Handler.cached' and 'Yesod.Core.Handler.cachedBy'
-module Yesod.Core.TypeCache (cached, cachedBy, TypeMap, KeyedTypeMap) where
+module Yesod.Core.TypeCache (cached, cacheGet, cacheSet, cachedBy, cacheByGet, cacheBySet, TypeMap, KeyedTypeMap) where
 
 import           Prelude hiding (lookup)
 import           Data.Typeable                      (Typeable, TypeRep, typeOf)
@@ -33,22 +33,30 @@ cached :: (Monad m, Typeable a)
        => TypeMap
        -> m a                       -- ^ cache the result of this action
        -> m (Either (TypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
-cached cache action = case clookup cache of
+cached cache action = case cacheGet cache of
     Just val -> return $ Right val
     Nothing -> do
         val <- action
-        return $ Left (cinsert val cache, val)
+        return $ Left (cacheSet val cache, val)
-  where
-    clookup :: Typeable a => TypeMap -> Maybe a
-    clookup c =
-        res
-      where
-        res = lookup (typeOf $ fromJust res) c >>= fromDynamic
-        fromJust :: Maybe a -> a
-        fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
 
-    cinsert :: Typeable a => a -> TypeMap -> TypeMap
+-- | Retrieves a value from the cache
-    cinsert v = insert (typeOf v) (toDyn v)
+--
+-- @since 1.6.10
+cacheGet :: Typeable a => TypeMap -> Maybe a
+cacheGet cache = res
+  where
+    res = lookup (typeOf $ fromJust res) cache >>= fromDynamic
+    fromJust :: Maybe a -> a
+    fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
+
+-- | Sets a value in the cache
+--
+-- @since 1.6.10
+cacheSet :: (Typeable a)
+         => a
+         -> TypeMap
+         -> TypeMap
+cacheSet v cache = insert (typeOf v) (toDyn v) cache
 
 -- | similar to 'cached'.
 -- 'cached' can only cache a single value per type.
@@ -65,19 +73,24 @@ cachedBy :: (Monad m, Typeable a)
          -> ByteString                     -- ^ a cache key
          -> m a                            -- ^ cache the result of this action
          -> m (Either (KeyedTypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
-cachedBy cache k action = case clookup k cache of
+cachedBy cache k action = case cacheByGet k cache of
     Just val -> return $ Right val
     Nothing -> do
         val <- action
-        return $ Left (cinsert k val cache, val)
+        return $ Left (cacheBySet k val cache, val)
-  where
-    clookup :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a
-    clookup key c =
-        res
-      where
-        res = lookup (typeOf $ fromJust res, key) c >>= fromDynamic
-        fromJust :: Maybe a -> a
-        fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
 
-    cinsert :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap
+-- | Retrieves a value from the keyed cache
-    cinsert key v = insert (typeOf v, key) (toDyn v)
+--
+-- @since 1.6.10
+cacheByGet :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a
+cacheByGet key c = res
+  where
+    res = lookup (typeOf $ fromJust res, key) c >>= fromDynamic
+    fromJust :: Maybe a -> a
+    fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
+
+-- | Sets a value in the keyed cache
+--
+-- @since 1.6.10
+cacheBySet :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap
+cacheBySet key v cache = insert (typeOf v, key) (toDyn v) cache

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

@@ -1,6 +1,5 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleInstances          #-}
@@ -8,20 +7,19 @@
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
 module Yesod.Core.Types where
 
+import Data.Aeson (ToJSON)
 import qualified Data.ByteString.Builder            as BB
-#if __GLASGOW_HASKELL__ < 710
-import           Control.Applicative                (Applicative (..))
-import           Control.Applicative                ((<$>))
-import           Data.Monoid                        (Monoid (..))
-#endif
 import           Control.Arrow                      (first)
 import           Control.Exception                  (Exception)
 import           Control.Monad                      (ap)
 import           Control.Monad.IO.Class             (MonadIO (liftIO))
 import           Control.Monad.Logger               (LogLevel, LogSource,
                                                      MonadLogger (..))
+import           Control.Monad.Primitive            (PrimMonad (..))
 import           Control.Monad.Trans.Resource       (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)
 import           Data.ByteString                    (ByteString)
 import qualified Data.ByteString.Lazy               as L
@@ -39,7 +37,6 @@ import           Data.Text                          (Text)
 import qualified Data.Text                          as T
 import qualified Data.Text.Lazy.Builder             as TBuilder
 import           Data.Time                          (UTCTime)
-import           Data.Typeable                      (Typeable)
 import           GHC.Generics                       (Generic)
 import           Language.Haskell.TH.Syntax         (Loc)
 import qualified Network.HTTP.Types                 as H
@@ -57,10 +54,9 @@ import           Yesod.Core.Internal.Util           (getTime, putTime)
 import           Yesod.Routes.Class                 (RenderRoute (..), ParseRoute (..))
 import           Control.Monad.Reader               (MonadReader (..))
 import Control.DeepSeq (NFData (rnf))
-import Control.DeepSeq.Generics (genericRnf)
 import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
 import Control.Monad.Logger (MonadLoggerIO (..))
-import UnliftIO (MonadUnliftIO (..), UnliftIO (..))
+import UnliftIO (MonadUnliftIO (..), SomeException)
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -187,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
@@ -201,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)
     }
 
@@ -236,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
@@ -288,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.
@@ -308,6 +316,20 @@ newtype RepXml = RepXml Content
 
 type ContentType = ByteString -- FIXME Text?
 
+-- | Wrapper around types so that Handlers can return a domain type, even when
+-- the data will eventually be encoded as JSON.
+-- Example usage in a type signature:
+--
+-- > postSignupR :: Handler (JSONResponse CreateUserResponse)
+--
+-- And in the implementation:
+--
+-- > return $ JSONResponse $ CreateUserResponse userId
+--
+-- @since 1.6.14
+data JSONResponse a where
+    JSONResponse :: ToJSON a => a -> JSONResponse a
+
 -- | Prevents a response body from being fully evaluated before sending the
 -- request.
 --
@@ -317,14 +339,30 @@ 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
-    deriving (Show, Eq, Typeable, Generic)
+        -- ^ 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.)
-instance NFData ErrorResponse where
+        -- HTTP code: 405.
-    rnf = genericRnf
+    deriving (Show, Eq, Generic)
+instance NFData ErrorResponse
 
 ----- header stuff
 -- | Headers to be added to a 'Result'.
@@ -356,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
@@ -371,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
@@ -378,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
@@ -401,7 +442,6 @@ data HandlerContents =
     | HCCreated !Text
     | HCWai !W.Response
     | HCWaiApp !W.Application
-    deriving Typeable
 
 instance Show HandlerContents where
     show (HCContent status (TypedContent t _)) = "HCContent " ++ show (status, t)
@@ -424,11 +464,14 @@ instance Monad (WidgetFor site) where
         unWidgetFor (f a) wd
 instance MonadIO (WidgetFor site) where
     liftIO = WidgetFor . const
+-- | @since 1.6.7
+instance PrimMonad (WidgetFor site) where
+    type PrimState (WidgetFor site) = PrimState IO
+    primitive = liftIO . primitive
 -- | @since 1.4.38
 instance MonadUnliftIO (WidgetFor site) where
-  {-# INLINE askUnliftIO #-}
+  {-# INLINE withRunInIO #-}
-  askUnliftIO = WidgetFor $ \wd ->
+  withRunInIO inner = WidgetFor $ \x -> inner $ flip unWidgetFor x
-                return (UnliftIO (flip unWidgetFor wd))
 instance MonadReader (WidgetData site) (WidgetFor site) where
     ask = WidgetFor return
     local f (WidgetFor g) = WidgetFor $ g . f
@@ -446,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
@@ -455,15 +498,18 @@ instance Monad (HandlerFor site) where
     HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r
 instance MonadIO (HandlerFor site) where
     liftIO = HandlerFor . const
+-- | @since 1.6.7
+instance PrimMonad (HandlerFor site) where
+    type PrimState (HandlerFor site) = PrimState IO
+    primitive = liftIO . primitive
 instance MonadReader (HandlerData site site) (HandlerFor site) where
     ask = HandlerFor return
     local f (HandlerFor g) = HandlerFor $ g . f
 
 -- | @since 1.4.38
 instance MonadUnliftIO (HandlerFor site) where
-  {-# INLINE askUnliftIO #-}
+  {-# INLINE withRunInIO #-}
-  askUnliftIO = HandlerFor $ \r ->
+  withRunInIO inner = HandlerFor $ \x -> inner $ flip unHandlerFor x
-                return (UnliftIO (flip unHandlerFor r))
 
 instance MonadThrow (HandlerFor site) where
     throwM = liftIO . throwM
@@ -534,9 +580,8 @@ instance MonadReader (HandlerData child master) (SubHandlerFor child master) whe
 
 -- | @since 1.4.38
 instance MonadUnliftIO (SubHandlerFor child master) where
-  {-# INLINE askUnliftIO #-}
+  {-# INLINE withRunInIO #-}
-  askUnliftIO = SubHandlerFor $ \r ->
+  withRunInIO inner = SubHandlerFor $ \x -> inner $ flip unSubHandlerFor x
-                return (UnliftIO (flip unSubHandlerFor r))
 
 instance MonadThrow (SubHandlerFor child master) where
     throwM = liftIO . throwM

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 -- | This is designed to be used as
 --
 -- > import qualified Yesod.Core.Unsafe as Unsafe
@@ -10,9 +9,6 @@ import Yesod.Core.Internal.Run (runFakeHandler)
 
 import Yesod.Core.Types
 import Yesod.Core.Class.Yesod
-#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid            (mempty, mappend)
-#endif
 import Control.Monad.IO.Class (MonadIO)
 
 -- | designed to be used as

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

@@ -8,7 +8,8 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE QuasiQuotes #-}
+
 -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
 -- generator, allowing you to create truly modular HTML components.
 module Yesod.Core.Widget
@@ -30,6 +31,12 @@ module Yesod.Core.Widget
       -- ** Head of page
     , setTitle
     , setTitleI
+    , setDescription
+    , setDescriptionI
+    , setDescriptionIdemp
+    , setDescriptionIdempI
+    , setOGType
+    , setOGImage
       -- ** CSS
     , addStylesheet
     , addStylesheetAttrs
@@ -57,11 +64,9 @@ import Text.Cassius
 import Text.Julius
 import Yesod.Routes.Class
 import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
-#if __GLASGOW_HASKELL__ < 710
-import Control.Applicative ((<$>))
-#endif
 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)
@@ -75,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
@@ -85,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
@@ -128,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 ()
@@ -148,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
@@ -164,18 +169,133 @@ instance ToWidgetHead site Javascript where
 instance ToWidgetHead site Html where
     toWidgetHead = toWidgetHead . const
 
--- | Set the page title. Calling 'setTitle' multiple times overrides previously
+-- | Set the page title.
--- set values.
+--
+-- Calling @setTitle@ or @setTitleI@ multiple times overrides previously set
+-- values.
+--
+-- SEO Notes:
+--
+--    * Title tags are the second most important on-page factor for SEO, after
+--      content
+--    * Every page should have a unique title tag
+--    * Start your title tag with your main targeted keyword
+--    * Don't stuff your keywords
+--    * Google typically shows 55-64 characters, so aim to keep your title
+--      length under 60 characters
 setTitle :: MonadWidget m => Html -> m ()
-setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty
 
--- | Set the page title. Calling 'setTitle' multiple times overrides previously
+-- | Set the localised page title.
--- set values.
+--
+-- n.b. See comments for @setTitle@
 setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
 setTitleI msg = do
     mr <- getMessageRender
     setTitle $ toHtml $ mr msg
 
+-- | Add description meta tag to the head of the page
+--
+-- Google does not use the description tag as a ranking signal, but the
+-- contents of this tag will likely affect your click-through rate since it
+-- shows up in search results.
+--
+-- The average length of the description shown in Google's search results is
+-- about 160 characters on desktop, and about 130 characters on mobile, at time
+-- of writing.
+--
+-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
+--
+-- @since 1.6.18
+setDescription :: MonadWidget m => Text -> m ()
+setDescription description =
+    toWidgetHead $ [hamlet|<meta name=description content=#{description}>|]
+
+{-# WARNING setDescription
+  [ "setDescription is not idempotent; we recommend setDescriptionIdemp instead"
+  , "Multiple calls to setDescription will insert multiple meta tags in the page head."
+  , "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \
+    \may need to change your layout to include pageDescription."
+  ]
+#-}
+
+-- | Add translated description meta tag to the head of the page
+--
+-- n.b. See comments for @setDescription@.
+--
+-- @since 1.6.18
+setDescriptionI
+  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)
+  => msg -> m ()
+setDescriptionI msg = do
+    mr <- getMessageRender
+    toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|]
+
+{-# WARNING setDescriptionI
+  [ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead"
+  , "Multiple calls to setDescriptionI will insert multiple meta tags in the page head."
+  , "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \
+    \may need to change your layout to include pageDescription."
+  ]
+#-}
+
+-- | Add description meta tag to the head of the page
+--
+-- Google does not use the description tag as a ranking signal, but the
+-- contents of this tag will likely affect your click-through rate since it
+-- shows up in search results.
+--
+-- The average length of the description shown in Google's search results is
+-- about 160 characters on desktop, and about 130 characters on mobile, at time
+-- of writing.
+--
+-- Unlike 'setDescription', this version is *idempotent* - calling it multiple
+-- times will result in only a single description meta tag in the head.
+--
+-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
+--
+-- @since 1.6.23
+setDescriptionIdemp :: MonadWidget m => Text -> m ()
+setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty
+
+-- | Add translated description meta tag to the head of the page
+--
+-- n.b. See comments for @setDescriptionIdemp@.
+--
+-- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple
+-- times will result in only a single description meta tag in the head.
+--
+-- @since 1.6.23
+setDescriptionIdempI
+  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)
+  => msg -> m ()
+setDescriptionIdempI msg = do
+    mr <- getMessageRender
+    setDescriptionIdemp $ mr msg
+
+-- | Add OpenGraph type meta tag to the head of the page
+--
+-- See all available OG types here: https://ogp.me/#types
+--
+-- @since 1.6.18
+setOGType :: MonadWidget m => Text -> m ()
+setOGType a = toWidgetHead $ [hamlet|<meta property="og:type" content=#{a}>|]
+
+-- | Add OpenGraph image meta tag to the head of the page
+--
+-- Best practices:
+--
+--    * Use custom images for shareable pages, e.g., homepage, articles, etc.
+--    * Use your logo or any other branded image for the rest of your pages.
+--    * Use images with a 1.91:1 ratio and minimum recommended dimensions of
+--      1200x630 for optimal clarity across all devices.
+--
+-- Source: https://ahrefs.com/blog/open-graph-meta-tags/
+--
+-- @since 1.6.18
+setOGImage :: MonadWidget m => Text -> m ()
+setOGImage a = toWidgetHead $ [hamlet|<meta property="og:image" content=#{a}>|]
+
 -- | Link to the specified local stylesheet.
 addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
 addStylesheet = flip addStylesheetAttrs []
@@ -185,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 ()
@@ -193,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
@@ -211,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 ()
@@ -219,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

@@ -1,5 +1,4 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE PatternGuards #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
 module Yesod.Routes.Parse
@@ -12,6 +11,7 @@ module Yesod.Routes.Parse
     , TypeTree (..)
     , dropBracket
     , nameToType
+    , isTvar
     ) where
 
 import Language.Haskell.TH.Syntax
@@ -36,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
 
@@ -65,7 +71,7 @@ parseRoutesNoCheck = QuasiQuoter
 -- invalid input.
 resourcesFromString :: String -> [ResourceTree String]
 resourcesFromString =
-    fst . parse 0 . filter (not . all (== ' ')) . lines . filter (/= '\r')
+    fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r')
   where
     parse _ [] = ([], [])
     parse indent (thisLine:otherLines)
@@ -259,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)
@@ -285,3 +296,12 @@ dropBracket str@('{':x) = case break (== '}') x of
     _ -> error $ "Unclosed bracket ('{'): " ++ str
 dropBracket x = x
 
+-- | If this line ends with a backslash, concatenate it together with the next line.
+--
+-- @since 1.6.8
+lineContinuations :: String -> [String] -> [String]
+lineContinuations this [] = [this]
+lineContinuations this below@(next:rest) = case unsnoc this of
+    Just (this', '\\') -> (this'++next):rest
+    _ -> this:below
+  where unsnoc s = if null s then Nothing else Just (init s, last s)

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/ParseRoute.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Yesod.Routes.TH.ParseRoute
     ( -- ** ParseRoute
@@ -45,8 +44,4 @@ mkParseRouteInstance cxt typ ress = do
     fixDispatch x = x
 
 instanceD :: Cxt -> Type -> [Dec] -> Dec
-#if MIN_VERSION_template_haskell(2,11,0)
 instanceD = InstanceD Nothing
-#else
-instanceD = InstanceD
-#endif

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

@@ -1,39 +1,93 @@
-{-# 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
-#if MIN_VERSION_template_haskell(2,11,0)
 import Language.Haskell.TH (conT)
-#endif
 import Language.Haskell.TH.Syntax
-#if MIN_VERSION_template_haskell(2,11,0)
 import Data.Bits (xor)
-#endif
 import Data.Maybe (maybeToList)
 import Control.Monad (replicateM)
 import Data.Text (pack)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Yesod.Routes.Class
-#if __GLASGOW_HASKELL__ < 710
+
-import Control.Applicative ((<$>))
+-- | General opts data type for generating yesod.
-import Data.Monoid (mconcat)
+--
-#endif
+-- 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{} = []
@@ -47,18 +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
-#elif MIN_VERSION_template_haskell(2,11,0)
-        dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]
 #else
-        let dec = DataD [] (mkName name) [] cons [''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
@@ -77,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|]
@@ -94,7 +147,12 @@ mkRenderRouteClauses =
         let cons y ys = InfixE (Just y) colon (Just ys)
         let pieces' = foldr cons (VarE a) piecesSingle
 
-        let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)
+        let body = LamE [TupP [VarP a, VarP b]] (TupE
+#if MIN_VERSION_template_haskell(2,16,0)
+                                                  $ map Just
+#endif
+                                                  [pieces', VarE b]
+                                                ) `AppE` (rr `AppE` VarE child)
 
         return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
 
@@ -105,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|]
@@ -129,11 +187,20 @@ mkRenderRouteClauses =
                     let cons y ys = InfixE (Just y) colon (Just ys)
                     let pieces = foldr cons (VarE a) piecesSingle
 
-                    return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
+                    return $ LamE [TupP [VarP a, VarP b]] (TupE
+#if MIN_VERSION_template_haskell(2,16,0)
+                                                            $ map Just
+#endif
+                                                            [pieces, VarE b]
+                                                          ) `AppE` (rr `AppE` VarE x)
                 _ -> do
                     colon <- [|(:)|]
                     let cons a b = InfixE (Just a) colon (Just b)
-                    return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]
+                    return $ TupE
+#if MIN_VERSION_template_haskell(2,16,0)
+                      $ map Just
+#endif
+                      [foldr cons piecesMulti piecesSingle, ListE []]
 
         return $ Clause [pat] (NormalB body) []
 
@@ -148,18 +215,28 @@ 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,12,0)
+#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)
+#elif MIN_VERSION_template_haskell(2,12,0)
     did <- DataInstD [] ''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)
-#elif MIN_VERSION_template_haskell(2,11,0)
+#else
     did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)
     let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
-#else
-    let did = DataInstD [] ''Route [typ] cons clazzes'
-    let sds = []
 #endif
     return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)
         [ did
@@ -167,25 +244,21 @@ mkRenderRouteInstance cxt typ ress = do
         ]
         : sds ++ decs
   where
-#if MIN_VERSION_template_haskell(2,11,0)
     clazzes standalone = if standalone `xor` null cxt then
           clazzes'
         else
           []
-#endif
+    clazzes' = instanceNamesFromOpts opts
-    clazzes' = [''Show, ''Eq, ''Read]
 
-#if MIN_VERSION_template_haskell(2,11,0)
 notStrict :: Bang
 notStrict = Bang NoSourceUnpackedness NoSourceStrictness
-#else
-notStrict :: Strict
-notStrict = NotStrict
-#endif
 
 instanceD :: Cxt -> Type -> [Dec] -> Dec
-#if MIN_VERSION_template_haskell(2,11,0)
 instanceD = InstanceD Nothing
-#else
+
-instanceD = InstanceD
+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

@@ -10,9 +10,6 @@ import Yesod.Routes.Class
 import Language.Haskell.TH.Syntax
 import Data.Set (fromList)
 import Data.Text (pack)
-#if __GLASGOW_HASKELL__ < 710
-import Control.Applicative ((<$>))
-#endif
 
 mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
 mkRouteAttrsInstance cxt typ ress = do
@@ -30,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 {..} =
@@ -42,8 +43,4 @@ goRes front Resource {..} =
     toText s = VarE 'pack `AppE` LitE (StringL s)
 
 instanceD :: Cxt -> Type -> [Dec] -> Dec
-#if MIN_VERSION_template_haskell(2,11,0)
 instanceD = InstanceD Nothing
-#else
-instanceD = InstanceD
-#endif

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

@@ -1,5 +1,5 @@
 {-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveLift #-}
 -- | Warning! This module is considered internal and may have breaking changes
 module Yesod.Routes.TH.Types
     ( -- * Data types
@@ -21,7 +21,7 @@ import Language.Haskell.TH.Syntax
 data ResourceTree typ
     = ResourceLeaf (Resource typ)
     | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ]
-    deriving (Show, Functor)
+    deriving (Lift, Show, Functor)
 
 resourceTreePieces :: ResourceTree typ -> [Piece typ]
 resourceTreePieces (ResourceLeaf r) = resourcePieces r
@@ -31,10 +31,6 @@ resourceTreeName :: ResourceTree typ -> String
 resourceTreeName (ResourceLeaf r) = resourceName r
 resourceTreeName (ResourceParent x _ _ _) = x
 
-instance Lift t => Lift (ResourceTree t) where
-    lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]
-    lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|]
-
 data Resource typ = Resource
     { resourceName :: String
     , resourcePieces :: [Piece typ]
@@ -42,24 +38,17 @@ data Resource typ = Resource
     , resourceAttrs :: [String]
     , resourceCheck :: CheckOverlap
     }
-    deriving (Show, Functor)
+    deriving (Lift, Show, Functor)
 
 type CheckOverlap = Bool
 
-instance Lift t => Lift (Resource t) where
-    lift (Resource a b c d e) = [|Resource a b c d e|]
-
 data Piece typ = Static String | Dynamic typ
-    deriving Show
+    deriving (Lift, Show)
 
 instance Functor Piece where
     fmap _ (Static s)  = Static s
     fmap f (Dynamic t) = Dynamic (f t)
 
-instance Lift t => Lift (Piece t) where
-    lift (Static s)  = [|Static  $(lift s)|]
-    lift (Dynamic t) = [|Dynamic $(lift t)|]
-
 data Dispatch typ =
     Methods
         { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end
@@ -69,17 +58,12 @@ data Dispatch typ =
         { subsiteType :: typ
         , subsiteFunc :: String
         }
-    deriving Show
+    deriving (Lift, Show)
 
 instance Functor Dispatch where
     fmap f (Methods a b) = Methods (fmap f a) b
     fmap f (Subsite a b) = Subsite (f a) b
 
-instance Lift t => Lift (Dispatch t) where
-    lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
-    lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]
-    lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]
-
 resourceMulti :: Resource typ -> Maybe typ
 resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
 resourceMulti _ = Nothing

yesod-core/test/RouteSpec.hs

@@ -17,7 +17,7 @@ import Test.HUnit ((@?=))
 import Data.Text (Text, pack, unpack, singleton)
 import Yesod.Routes.Class hiding (Route)
 import qualified Yesod.Routes.Class as YRC
-import Yesod.Routes.Parse (parseRoutesNoCheck, parseTypeTree, TypeTree (..))
+import Yesod.Routes.Parse (parseRoutesFile, parseRoutesNoCheck, parseTypeTree, TypeTree (..))
 import Yesod.Routes.Overlap (findOverlapNames)
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
@@ -219,11 +219,17 @@ main = hspec $ do
         it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"]
             @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q')
 
-    describe "parsing" $ do
+    describe "route parsing" $ do
         it "subsites work" $ do
             parseRoute ([pack "subsite", pack "foo"], [(pack "bar", pack "baz")]) @?=
                 Just (SubsiteR $ MySubRoute ([pack "foo"], [(pack "bar", pack "baz")]))
 
+    describe "routing table parsing" $ do
+        it "recognizes trailing backslashes as line continuation directives" $ do
+            let routes :: [ResourceTree String]
+                routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations.yesodroutes")
+            length routes @?= 3
+
     describe "overlap checking" $ do
         it "catches overlapping statics" $ do
             let routes :: [ResourceTree String]

yesod-core/test/YesodCoreTest.hs

@@ -5,18 +5,27 @@ 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
 import qualified YesodCoreTest.RequestBodySize as RequestBodySize
 import qualified YesodCoreTest.Json as Json
+
+-- Skip on Windows, see https://github.com/yesodweb/yesod/issues/1523#issuecomment-398278450
+#if !WINDOWS
 import qualified YesodCoreTest.RawResponse as RawResponse
+#endif
+
 import qualified YesodCoreTest.Streaming as Streaming
 import qualified YesodCoreTest.Reps as Reps
 import qualified YesodCoreTest.Auth as Auth
@@ -35,15 +44,19 @@ specs = do
       mediaTest
       linksTest
       noOverloadedTest
+      subSubTest
       internalRequestTest
       errorHandlingTest
       cacheTest
+      parameterizedSiteTest
       WaiSubsite.specs
       Redirect.specs
       JsLoader.specs
       RequestBodySize.specs
       Json.specs
+#if !WINDOWS
       RawResponse.specs
+#endif
       Streaming.specs
       Reps.specs
       Auth.specs
@@ -52,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/Cache.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE Rank2Types #-}
 module YesodCoreTest.Cache
     ( cacheTest
@@ -22,10 +21,8 @@ import qualified Data.ByteString.Lazy.Char8 as L8
 data C = C
 
 newtype V1 = V1 Int
-    deriving Typeable
 
 newtype V2 = V2 Int
-    deriving Typeable
 
 mkYesod "C" [parseRoutes|
 /    RootR GET
@@ -46,7 +43,14 @@ getRootR = do
     V2 v2a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
     V2 v2b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
 
-    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b]
+    cacheBySet "3" (V2 3)
+    V2 v3a <- cacheByGet "3" >>= \x ->
+      case x of
+        Just y -> return y
+        Nothing -> error "must be Just"
+    V2 v3b <- cachedBy "3" $ (pure $ V2 4)
+
+    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b]
 
 getKeyR :: Handler RepPlain
 getKeyR = do
@@ -60,7 +64,15 @@ getKeyR = do
     V2 v3a <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
     V2 v3b <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
 
-    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b]
+
+    cacheBySet "4" (V2 4)
+    V2 v4a <- cacheByGet "4" >>= \x ->
+      case x of
+        Just y -> return y
+        Nothing -> error "must be Just"
+    V2 v4b <- cachedBy "4" $ (pure $ V2 5)
+
+    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b, v4a, v4b]
 
 getNestedR :: Handler RepPlain
 getNestedR = getNested cached
@@ -86,12 +98,12 @@ cacheTest =
     it "cached" $ runner $ do
       res <- request defaultRequest
       assertStatus 200 res
-      assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res
+      assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res
 
     it "cachedBy" $ runner $ do
       res <- request defaultRequest { pathInfo = ["key"] }
       assertStatus 200 res
-      assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res
+      assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3, 4, 4 :: Int]) res
 
     it "nested cached" $ runner $ do
       res <- request defaultRequest { pathInfo = ["nested"] }

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
 
@@ -40,6 +51,15 @@ mkYesod "App" [parseRoutes|
 /file-bad-name FileBadNameR GET
 
 /good-builder GoodBuilderR GET
+
+/auth-not-accepted AuthNotAcceptedR GET
+/auth-not-adequate AuthNotAdequateR GET
+/args-not-valid ArgsNotValidR POST
+/only-plain-text OnlyPlainTextR GET
+
+/thread-killed ThreadKilledR GET
+/connection-closed-by-peer ConnectionClosedPeerR GET
+/sleep-sec SleepASecR GET
 |]
 
 overrideStatus :: Status
@@ -106,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
@@ -119,6 +156,18 @@ getErrorR 9 = setUltDest (undefined :: Text)
 getErrorR 10 = setMessage undefined
 getErrorR x = error $ "getErrorR: " ++ show x
 
+getAuthNotAcceptedR :: Handler TypedContent
+getAuthNotAcceptedR = notAuthenticated
+
+getAuthNotAdequateR :: Handler TypedContent
+getAuthNotAdequateR = permissionDenied "That doesn't belong to you. "
+
+postArgsNotValidR :: Handler TypedContent
+postArgsNotValidR = invalidArgs ["Doesn't matter.", "Don't want it."]
+
+getOnlyPlainTextR :: Handler TypedContent
+getOnlyPlainTextR = selectRep $ provideRepType "text/plain" $ return ("Only plain text." :: Text)
+
 errorHandlingTest :: Spec
 errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "says not found" caseNotFound
@@ -132,6 +181,15 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "file with bad name" caseFileBadName
       it "builder includes content-length" caseGoodBuilder
       forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i)
+      it "accept DVI file, invalid args -> 400" caseDviInvalidArgs
+      it "accept audio, not authenticated -> 401" caseAudioNotAuthenticated
+      it "accept CSS, permission denied -> 403" caseCssPermissionDenied
+      it "accept image, non-existent path -> 404" caseImageNotFound
+      it "accept video, bad method -> 405" caseVideoBadMethod
+      it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows
+      it "custom config rethrows an exception" caseCustomExceptionRethrows
+      it "thread killed rethrow" caseThreadKilledRethrow
+      it "can timeout a runner" canTimeoutARunner
 
 runner :: Session a -> IO a
 runner f = toWaiApp App >>= runSession f
@@ -222,3 +280,97 @@ caseError i = runner $ do
     ReaderT $ \r -> StateT $ \s -> runStateT (runReaderT (assertStatus 500 res) r) s `E.catch` \e -> do
         liftIO $ print res
         E.throwIO (e :: E.SomeException)
+
+caseDviInvalidArgs :: IO ()
+caseDviInvalidArgs = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["args-not-valid"]
+            , requestMethod = "POST"
+            , requestHeaders =
+                ("accept", "application/x-dvi") : requestHeaders defaultRequest
+            }
+    assertStatus 400 res
+
+caseAudioNotAuthenticated :: IO ()
+caseAudioNotAuthenticated = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["auth-not-accepted"]
+            , requestHeaders =
+                ("accept", "audio/mpeg") : requestHeaders defaultRequest
+            }
+    assertStatus 401 res
+
+caseCssPermissionDenied :: IO ()
+caseCssPermissionDenied = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["auth-not-adequate"]
+            , requestHeaders =
+                ("accept", "text/css") : requestHeaders defaultRequest
+            }
+    assertStatus 403 res
+
+caseImageNotFound :: IO ()
+caseImageNotFound = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["not_a_path"]
+            , requestHeaders =
+                ("accept", "image/jpeg") : requestHeaders defaultRequest
+            }
+    assertStatus 404 res
+
+caseVideoBadMethod :: IO ()
+caseVideoBadMethod = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["good-builder"]
+            , requestMethod = "DELETE"
+            , requestHeaders =
+                ("accept", "video/webm") : requestHeaders defaultRequest
+            }
+    assertStatus 405 res
+
+fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e
+fromExceptionUnwrap se
+  | Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e
+  | Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e
+  | otherwise = E.fromException se
+
+
+caseThreadKilledRethrow :: IO ()
+caseThreadKilledRethrow =
+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
+                                (Just ThreadKilled) -> True
+                                _ -> False
+  where
+  testcode = runner $ do
+                res <- request defaultRequest { pathInfo = ["thread-killed"] }
+                assertStatus 500 res
+                assertBodyContains "Internal Server Error" res
+
+caseDefaultConnectionCloseRethrows :: IO ()
+caseDefaultConnectionCloseRethrows =
+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
+                                  Just Warp.ConnectionClosedByPeer -> True
+                                  _ -> False
+
+  where
+  testcode = runner $ do
+      _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] }
+      pure ()
+
+caseCustomExceptionRethrows :: IO ()
+caseCustomExceptionRethrows =
+  shouldThrow testcode $ \case Custom.MkMyException -> True
+  where
+    testcode = customAppRunner $ do
+      _res <- request defaultRequest { pathInfo = ["throw-custom-exception"] }
+      pure ()
+    customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f
+
+
+canTimeoutARunner :: IO ()
+canTimeoutARunner = do
+  res <- timeout 1000 $ runner $ do
+    res <- request defaultRequest { pathInfo = ["sleep-sec"] }
+    assertStatus 200 res -- if 500, it's catching the timeout exception
+    pure () -- it should've timeout by now, either being 500 or Nothing
+  res `shouldBe` Nothing -- make sure that pure statement didn't happen.

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/Header.hs

@@ -69,9 +69,16 @@ header3Test = do
     assertHeader "michael" "snoyman" res
     assertHeader "yesod" "book" res
 
+xssHeaderTest :: IO ()
+xssHeaderTest = do
+  runner $ do
+    res <- request defaultRequest {pathInfo = decodePathSegments "/header1"}
+    assertHeader "X-XSS-Protection" "1; mode=block" res
+
 headerTest :: Spec
 headerTest =
   describe "Test.Header" $ do
     it "addHeader" addHeaderTest
     it "multiple header" multipleHeaderTest
     it "persist headers" header3Test
+    it "has X-XSS-Protection: 1; mode=block" xssHeaderTest

yesod-core/test/YesodCoreTest/Json.hs

@@ -23,7 +23,7 @@ instance Yesod App
 
 getHomeR :: Handler RepPlain
 getHomeR = do
-    val <- requireJsonBody
+    val <- requireInsecureJsonBody
     case Map.lookup ("foo" :: Text) val of
         Nothing -> invalidArgs ["foo not found"]
         Just foo -> return $ RepPlain $ toContent (foo :: Text)

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/RawResponse.hs

@@ -13,15 +13,13 @@ import qualified Data.ByteString.Char8 as S8
 import Data.Conduit
 import qualified Data.Conduit.Binary as CB
 import Data.Char (toUpper)
-import Control.Exception (try, IOException)
 import Data.Conduit.Network
-import Network.Socket (close)
 import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async (withAsync)
+import Control.Concurrent.Async (race)
 import Control.Monad.Trans.Resource (register)
 import Data.IORef
-import Data.Streaming.Network (bindPortTCP)
 import Network.HTTP.Types (status200)
+import Network.Wai.Handler.Warp (testWithApplication)
 
 mkYesod "App" [parseRoutes|
 / HomeR GET
@@ -56,53 +54,38 @@ getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 []
     flush
     send " world"
 
-getFreePort :: IO Int
+allowFiveSeconds :: IO a -> IO a
-getFreePort = do
+allowFiveSeconds = fmap (either id id) . race (threadDelay 5000000 >> error "timed out")
-    loop 43124
-  where
-    loop port = do
-        esocket <- try $ bindPortTCP port "*"
-        case esocket of
-            Left (_ :: IOException) -> loop (succ port)
-            Right socket -> do
-                close socket
-                return port
 
 specs :: Spec
 specs = do
     describe "RawResponse" $ do
-        it "works" $ do
+        it "works" $ allowFiveSeconds $ testWithApplication (toWaiApp App) $ \port -> do
-            port <- getFreePort
+            runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
-            withAsync (warp port App) $ \_ -> do
+                runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad
-                threadDelay 100000
+                runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO")
-                runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
+                runConduit $ yield "WORLd" .| appSink ad
-                    runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad
+                runConduit (appSource ad .| await) >>= (`shouldBe` Just "WORLD")
-                    runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO")
-                    runConduit $ yield "WORLd" .| appSink ad
-                    runConduit (appSource ad .| await) >>= (`shouldBe` Just "WORLD")
 
-    let body req = do
+    let body req = allowFiveSeconds $ testWithApplication (toWaiApp App) $ \port -> do
-            port <- getFreePort
+            runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
-            withAsync (warp port App) $ \_ -> do
+                runConduit $ yield req .| appSink ad
-                threadDelay 100000
+                runConduit $ appSource ad .| CB.lines .| do
-                runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
+                    let loop = do
-                    runConduit $ yield req .| appSink ad
+                            x <- await
-                    runConduit $ appSource ad .| CB.lines .| do
+                            case x of
-                        let loop = do
+                                Nothing -> return ()
-                                x <- await
+                                Just "\r" -> return ()
-                                case x of
+                                _ -> loop
-                                    Nothing -> return ()
+                    loop
-                                    Just "\r" -> return ()
-                                    _ -> loop
-                        loop
 
-                        Just "0005\r" <- await
+                    Just "0005\r" <- await
-                        Just "hello\r" <- await
+                    Just "hello\r" <- await
 
-                        Just "0006\r" <- await
+                    Just "0006\r" <- await
-                        Just " world\r" <- await
+                    Just " world\r" <- await
 
-                        return ()
+                    return ()
     it "sendWaiResponse + responseStream" $ do
         body "GET /wai-stream HTTP/1.1\r\n\r\n"
     it "sendWaiApplication + responseStream" $ do

yesod-core/test/YesodCoreTest/Reps.hs

@@ -85,7 +85,6 @@ specs = do
     test "text/html" "HTML"
     test specialHtml "HTMLSPECIAL"
     testRequest 200 (acceptRequest "application/json") { pathInfo = ["json"] } "{\"message\":\"Invalid Login\"}"
-    testRequest 406 (acceptRequest "text/foo") "no match found for accept header"
     test "text/*" "HTML"
     test "*/*" "HTML"
   describe "routeAttrs" $ do

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/test/fixtures/routes_with_line_continuations.yesodroutes

@@ -0,0 +1,11 @@
+-- This fixture to test line continuations is in a separate file
+-- because when I put it in an in-line quasi-quotation, the compiler
+-- performed the line continuations processing itself.
+
+/foo1 \
+    Foo1
+/foo2 Foo2
+/foo3 \
+    Foo3 \
+    GET POST \
+    !foo

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.2
+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,53 +17,54 @@ extra-source-files:
   test/YesodCoreTest/JsLoaderSites/Bottom.hs
   test/en.msg
   test/test.hs
+  test/fixtures/routes_with_line_continuations.yesodroutes
   ChangeLog.md
   README.md
 
 library
-    build-depends:   base                  >= 4.9      && < 5
+    default-language: Haskell2010
-                   , time                  >= 1.5
+    hs-source-dirs: src
-                   , wai                   >= 3.0
+
-                   , wai-extra             >= 3.0.7
+    build-depends:   base                  >= 4.10     && < 5
-                   , bytestring            >= 0.10.2
-                   , text                  >= 0.7
-                   , template-haskell
-                   , path-pieces           >= 0.1.2    && < 0.3
-                   , shakespeare           >= 2.0
-                   , transformers          >= 0.4
-                   , mtl
-                   , clientsession         >= 0.9.1    && < 0.10
-                   , random                >= 1.0.0.2  && < 1.2
-                   , cereal                >= 0.3
-                   , old-locale            >= 1.0.0.2  && < 1.1
-                   , containers            >= 0.2
-                   , unordered-containers  >= 0.2
-                   , cookie                >= 0.4.3    && < 0.5
-                   , http-types            >= 0.7
-                   , case-insensitive      >= 0.2
-                   , parsec                >= 2        && < 3.2
-                   , directory             >= 1
-                   , vector                >= 0.9      && < 0.13
                    , aeson                 >= 1.0
-                   , fast-logger           >= 2.2
+                   , attoparsec-aeson      >= 2.1
-                   , wai-logger            >= 0.2
+                   , auto-update
-                   , monad-logger          >= 0.3.10   && < 0.4
-                   , conduit               >= 1.3
-                   , resourcet             >= 1.2
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.7.1
-                   , safe
+                   , bytestring            >= 0.10.2
-                   , warp                  >= 3.0.2
+                   , case-insensitive      >= 0.2
-                   , unix-compat
+                   , cereal                >= 0.3
+                   , clientsession         >= 0.9.1    && < 0.10
+                   , conduit               >= 1.3
                    , conduit-extra
+                   , containers            >= 0.2
+                   , cookie                >= 0.4.3    && < 0.5
                    , deepseq               >= 1.3
-                   , deepseq-generics
+                   , entropy
-                   , primitive
+                   , fast-logger           >= 2.2
-                   , word8
+                   , http-types            >= 0.7
-                   , auto-update
+                   , memory
-                   , semigroups
+                   , monad-logger          >= 0.3.10   && < 0.4
-                   , byteable
+                   , mtl
+                   , parsec                >= 2        && < 3.2
+                   , path-pieces           >= 0.1.2    && < 0.3
+                   , primitive             >= 0.6
+                   , random                >= 1.0.0.2  && < 1.3
+                   , resourcet             >= 1.2
+                   , shakespeare           >= 2.0
+                   , template-haskell      >= 2.11
+                   , text                  >= 0.7
+                   , time                  >= 1.5
+                   , transformers          >= 0.4
+                   , unix-compat
                    , unliftio
+                   , unordered-containers  >= 0.2
+                   , vector                >= 0.9      && < 0.14
+                   , wai                   >= 3.2
+                   , wai-extra             >= 3.0.7
+                   , wai-logger            >= 0.2
+                   , warp                  >= 3.0.2
+                   , word8
 
     exposed-modules: Yesod.Core
                      Yesod.Core.Content
@@ -99,17 +100,15 @@ 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, .
+    hs-source-dirs: test, src
 
     other-modules: Hierarchy
                    Yesod.Routes.Class
@@ -123,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
@@ -136,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
@@ -147,6 +147,7 @@ test-suite tests
                    YesodCoreTest.Header
                    YesodCoreTest.Csrf
                    YesodCoreTest.ErrorHandling
+                   YesodCoreTest.ErrorHandling.CustomApp
                    YesodCoreTest.Exceptions
                    YesodCoreTest.InternalRequest
                    YesodCoreTest.JsLoader
@@ -156,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
@@ -168,49 +174,51 @@ test-suite tests
                    YesodCoreTest.StubSslOnly
                    YesodCoreTest.StubStrictSameSite
                    YesodCoreTest.StubUnsecured
+                   YesodCoreTest.SubSub
+                   YesodCoreTest.SubSubData
                    YesodCoreTest.WaiSubsite
                    YesodCoreTest.Widget
                    YesodCoreTest.YesodTest
 
     cpp-options:   -DTEST
-    build-depends: base
+    if os(windows)
-                  ,hspec >= 1.3
+        cpp-options: -DWINDOWS
-                  ,hspec-expectations
+    build-depends:  base
-                  ,clientsession
-                  ,wai >= 3.0
-                  ,yesod-core
-                  ,bytestring
-                  ,text
-                  ,http-types
-                  , random
-                  ,HUnit
-                  ,QuickCheck >= 2 && < 3
-                  ,transformers
-                  , conduit
-                  , containers
-                  , resourcet
-                  , network
                   , async
+                  , bytestring
+                  , clientsession
+                  , conduit
                   , conduit-extra
+                  , containers
+                  , cookie >= 0.4.1    && < 0.5
+                  , hspec >= 1.3
+                  , hspec-expectations
+                  , http-types
+                  , network
+                  , random
+                  , resourcet
                   , shakespeare
                   , streaming-commons
-                  , wai-extra
+                  , text
-                  , cookie >= 0.4.1    && < 0.5
+                  , transformers
                   , unliftio
-    ghc-options:     -Wall
+                  , wai >= 3.0
-    extensions: TemplateHaskell
+                  , wai-extra
+                  , warp
+                  , yesod-core
+    ghc-options:     -Wall -threaded
+    other-extensions: TemplateHaskell
 
 benchmark widgets
+    default-language: Haskell2010
     type: exitcode-stdio-1.0
     hs-source-dirs: bench
     build-depends:  base
-                  , gauge
-                  , bytestring
-                  , text
-                  , transformers
-                  , yesod-core
                   , blaze-html
+                  , bytestring
+                  , gauge
                   , shakespeare
+                  , text
     main-is:        widget.hs
     ghc-options:    -Wall -O2
 

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,21 +8,20 @@ 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
-    build-depends:   base                  >= 4        && < 5
+    default-language: Haskell2010
-                   , yesod-core            == 1.6.*
+    build-depends:   base                  >= 4.10     && < 5
-                   , conduit               >= 1.3
-                   , wai                   >= 1.3
-                   , wai-eventsource       >= 1.3
-                   , wai-extra
                    , blaze-builder
+                   , conduit               >= 1.3
                    , transformers
+                   , wai                   >= 1.3
+                   , wai-extra
+                   , yesod-core            == 1.6.*
     exposed-modules: Yesod.EventSource
     ghc-options:     -Wall
 

yesod-form-multi/ChangeLog.md

@@ -0,0 +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
+
+[#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/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2019 James Burton
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

yesod-form-multi/README.md

@@ -0,0 +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`.

yesod-form-multi/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

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

@@ -0,0 +1,517 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE QuasiQuotes  #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+
+-- | A module providing a means of creating multiple input forms without
+-- the need to submit the form to generate a new input field unlike
+-- in "MassInput".
+module Yesod.Form.MultiInput
+    ( MultiSettings (..)
+    , MultiView (..)
+    , 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, 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
+import Yesod.Form.Types
+
+#ifdef MIN_VERSION_shakespeare(2,0,18)
+#if MIN_VERSION_shakespeare(2,0,18)
+#else
+import Text.Julius (ToJavascript (..))
+instance ToJavascript String where toJavascript = toJavascript . toJSON
+instance ToJavascript Text where toJavascript = toJavascript . toJSON
+#endif
+#endif
+
+-- | 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.
+    , 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.
+    }
+
+-- | 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"
+    "btn btn-danger"
+    "help-block"
+    "has-error"
+    Nothing Nothing (Just errW)
+    where
+        errW err = 
+            [whamlet|
+                <span .help-block>#{err}
+            |]
+
+-- | 'MultiSettings' for Bootstrap 4.
+--
+-- @since 1.6.0
+bs4Settings :: MultiSettings site
+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
+    -> FieldSettings site
+    -> [a]
+    -> Int
+    -> MultiSettings site
+    -> AForm m [a]
+amulti field fs defs minVals ms = formToAForm $
+    liftM (second return) mform
+    where
+        mform = do
+            (fr, MultiView {..}) <- mmulti field fs defs minVals ms
+
+            let (fv : _) = mvFields
+                widget = do
+                    [whamlet|
+                        $maybe tooltip <- fvTooltip fv
+                            <small .#{msTooltipClass ms}>#{tooltip}
+
+                        ^{fvInput mvCounter}
+
+                        $forall fv <- mvFields
+                            ^{fvInput fv}
+
+                        ^{fvInput mvAddBtn}
+                    |]
+                view = FieldView
+                    { fvLabel = fvLabel fv
+                    , fvTooltip = Nothing
+                    , fvId = fvId fv
+                    , fvInput = widget
+                    , fvErrors = fvErrors mvAddBtn
+                    , fvRequired = False
+                    }
+            
+            return (fr, view)
+
+-- | Converts a form field into a monadic form containing an arbitrary
+-- number of the given fields as specified by the user. Returns a list
+-- of results, failing if the length of the list is less than the minimum
+-- requested values.
+--
+-- @since 1.6.0
+mmulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
+    => Field m a
+    -> FieldSettings site
+    -> [a]
+    -> Int
+    -> MultiSettings site
+    -> MForm m (FormResult [a], MultiView site)
+mmulti field fs defs minVals' ms = do
+    wrapperClass <- lift newIdent
+    let minVals = if minVals' < 0 then 0 else minVals'
+    mhelperMulti field fs wrapperClass defs minVals ms
+
+-- Helper function, does most of the work for mmulti.
+mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
+    => Field m a
+    -> FieldSettings site
+    -> Text
+    -> [a]
+    -> Int
+    -> MultiSettings site
+    -> MForm m (FormResult [a], MultiView site)
+mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals MultiSettings {..} = do
+    mp <- askParams
+    (_, site, langs) <- ask
+    name <- maybe newFormIdent return fsName
+    theId <- lift $ maybe newIdent return fsId
+    cName <- newFormIdent
+    cid <- lift newIdent
+    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 = [(i, (mkName i, mkId i)) | i <- [0 .. c]]
+        onMissingSucc _ _ = FormSuccess Nothing
+        onMissingFail m l = FormFailure [renderMessage m l MsgValueRequired]
+        isSuccNothing r = case r of
+            FormSuccess Nothing -> True
+            _ -> False
+
+    mfs <- askFiles
+    
+    -- get counter value (starts counting from 0)
+    cr@(cRes, _) <- case mp of
+        Nothing -> return (FormMissing, Right cDef)
+        Just p -> mkRes intField cfs p mfs cName onMissingFail FormSuccess
+
+    -- generate counter view
+    cView <- mkView intField cfs cr Nothing Nothing msWrapperErrClass cid cName True
+
+    let counter = case cRes of
+            FormSuccess c -> c
+            _             -> cDef
+
+    -- get results of fields
+    results <- case mp of
+        Nothing -> return $
+            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 . 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' ((c, (n,i)), r@(res, _)) = do
+                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
+                [] -> [((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
+    
+    -- check values
+    let rs' = [ fmap fromJust r | r <- rs
+                                , not $ isSuccNothing r ]
+        err = T.pack $ "Please enter at least " ++ show minVals ++ " values."
+        (res, tooFewVals) = 
+            case foldr (<*>) (FormSuccess []) (map (fmap $ (:)) rs') of
+                FormSuccess xs ->
+                    if length xs < minVals
+                        then (FormFailure [err], True)
+                        else (FormSuccess xs, False)
+                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">
+                    $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_#{rawJS theId} = 0;
+                    $('##{rawJS addBtnId}').click(function() {
+                        extraFields_#{rawJS theId}++;
+                        var newNumber = parseInt(#{show counter}) + extraFields_#{rawJS theId};
+                        $("#" + #{cid}).val(newNumber);
+                        var newName = #{name} + "-" + newNumber;
+                        var newId = #{theId} + "-" + newNumber;
+                        var newDelId = #{delBtnPrefix} + newId;
+                        
+                        // get new wrapper and remove old error messages
+                        var newWrapper = $('.#{rawJS wrapperClass}').first().clone();
+                        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}');
+                    });
+                |]
+
+        btnView = FieldView
+            { fvLabel = toHtml $ mr2 ("" :: Text)
+            , fvTooltip = Nothing
+            , fvId = addBtnId
+            , fvInput = btnWidget
+            , fvErrors = if tooFewVals then Just $ toHtml err else Nothing
+            , fvRequired = False
+            }
+
+    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.
+mkRes :: (site ~ HandlerSite m, MonadHandler m)
+    => Field m a
+    -> FieldSettings site
+    -> Env
+    -> Maybe FileEnv
+    -> Text
+    -> (site -> [Text] -> FormResult b)
+    -> (a -> FormResult b)
+    -> MForm m (FormResult b, Either Text a)
+mkRes Field {..} FieldSettings {..} p mfs name onMissing onFound = do
+    tell fieldEnctype
+    (_, site, langs) <- ask
+    let mvals = fromMaybe [] $ Map.lookup name p
+        files = fromMaybe [] $ mfs >>= Map.lookup name
+    emx <- lift $ fieldParse mvals files
+    return $ case emx of
+        Left msg -> (FormFailure [renderMessage site langs msg], maybe (Left "") Left (listToMaybe mvals))
+        Right mx ->
+            case mx of
+                Nothing -> (onMissing site langs, Left "") 
+                Just x -> (onFound x, Right x)
+
+-- Generate a FieldView for the given field with the given result.
+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) 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 = fv
+        , fvErrors = merr
+        , fvRequired = isReq
+        }

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

@@ -0,0 +1,39 @@
+name:            yesod-form-multi
+version:         1.7.0.2
+license:         MIT
+license-file:    LICENSE
+author:          James Burton <jamesejburton@gmail.com>
+maintainer:      James Burton <jamesejburton@gmail.com>
+synopsis:        Multi-input form handling for Yesod Web Framework
+category:        Web, Yesod
+stability:       Stable
+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>.
+extra-source-files: ChangeLog.md
+                    README.md
+
+flag network-uri
+  description: Get Network.URI from the network-uri package
+  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.8
+
+    if flag(network-uri)
+      build-depends: network-uri >= 2.6
+
+    exposed-modules: Yesod.Form.MultiInput
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: https://github.com/yesodweb/yesod

yesod-form/ChangeLog.md

@@ -1,3 +1,61 @@
+# 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)
+
+## 1.6.6
+
+* Added `mreqMsg` for `mreq` functionality with a configurable MsgValueRequired [#1613](https://github.com/yesodweb/yesod/pull/1613)
+
+## 1.6.5
+
+* Add `.sr-only` to labels in `renderBootstrap3` when they are null.
+
+## 1.6.4
+
+* Make FormResult an instance of Eq
+
+## 1.6.3
+
+* make sure a select field does not lose the selected value even if a validation on the
+  field fails
+
+## 1.6.2
+
+* Move `addClass` from private/undocumented in `Yesod.Form.Bootstrap3` to `Yesod.Form.Functions` [#1510](https://github.com/yesodweb/yesod/pull/1510)
+* Add `Yesod.Form.Functions.removeClass` [#1510](https://github.com/yesodweb/yesod/pull/1510)
+* Changed `Textarea` to derive `IsString` [#1514](https://github.com/yesodweb/yesod/pull/1514)
+* Expose `selectFieldHelper` [#1530](https://github.com/yesodweb/yesod/pull/1530)
+
 ## 1.6.1
 
 * Explicitly define `(<>)` in the `Semigroup` instance for `Enctype`

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/Bootstrap3.hs

@@ -32,10 +32,8 @@ import Control.Arrow (second)
 import Control.Monad (liftM)
 import Data.Text (Text)
 import Data.String (IsString(..))
+import qualified Text.Blaze.Internal as Blaze
 import Yesod.Core
-
-import qualified Data.Text as T
-
 import Yesod.Form.Types
 import Yesod.Form.Functions
 
@@ -82,12 +80,6 @@ withSmallInput fs = fs { fsAttrs = newAttrs }
     where newAttrs = addClass "input-sm" (fsAttrs fs)
 
 
-addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
-addClass klass []                    = [("class", klass)]
-addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
-addClass klass (other         :rest) = other : addClass klass rest
-
-
 -- | How many bootstrap grid columns should be taken (see
 -- 'BootstrapFormLayout').
 --
@@ -163,7 +155,7 @@ renderBootstrap3 formLayout aform fragment = do
                 $case formLayout
                   $of BootstrapBasicForm
                     $if fvId view /= bootstrapSubmitId
-                      <label for=#{fvId view}>#{fvLabel view}
+                      <label :Blaze.null (fvLabel view):.sr-only for=#{fvId view}>#{fvLabel view}
                     ^{fvInput view}
                     ^{helpWidget view}
                   $of BootstrapInlineForm
@@ -173,7 +165,7 @@ renderBootstrap3 formLayout aform fragment = do
                     ^{helpWidget view}
                   $of BootstrapHorizontalForm labelOffset labelSize inputOffset inputSize
                     $if fvId view /= bootstrapSubmitId
-                      <label .control-label .#{toOffset labelOffset} .#{toColumn labelSize} for=#{fvId view}>#{fvLabel view}
+                      <label :Blaze.null (fvLabel view):.sr-only .control-label .#{toOffset labelOffset} .#{toColumn labelSize} for=#{fvId view}>#{fvLabel view}
                       <div .#{toOffset inputOffset} .#{toColumn inputSize}>
                         ^{fvInput view}
                         ^{helpWidget view}

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.
@@ -42,10 +43,13 @@ module Yesod.Form.Fields
     , fileAFormOpt
       -- * Options
       -- $optionsOverview
+    , selectFieldHelper
     , selectField
     , selectFieldList
+    , selectFieldListGrouped
     , radioField
     , radioFieldList
+    , withRadioField
     , checkboxesField
     , checkboxesFieldList
     , multiSelectField
@@ -53,10 +57,14 @@ module Yesod.Form.Fields
     , Option (..)
     , OptionList (..)
     , mkOptionList
+    , mkOptionListGrouped
     , optionsPersist
     , optionsPersistKey
     , optionsPairs
+    , optionsPairsGrouped
     , optionsEnum
+    , colorField
+    , datetimeLocalField
     ) where
 
 import Yesod.Form.Types
@@ -67,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)
@@ -79,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)
 
@@ -91,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
@@ -106,10 +115,14 @@ import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput,
 
 import Yesod.Persist.Core
 
+import Data.String (IsString)
+
 #if !MIN_VERSION_base(4,8,0)
 import Data.Monoid
 #endif
 
+import Data.Char (isHexDigit)
+
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
 
@@ -166,20 +179,20 @@ timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Tim
 timeField = timeFieldTypeTime
 
 -- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'.
--- 
+--
 -- 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 :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
 timeFieldTypeTime = timeFieldOfType "time"
 
 -- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system).
 --
 -- This function exists for backwards compatibility with the old implementation of 'timeField', which used to use @type="text"@. Consider using 'timeField' or 'timeFieldTypeTime' for improved UX and validation from the browser.
--- 
+--
 -- 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"
 
@@ -212,12 +225,12 @@ $newline never
   where showVal = either id (pack . renderHtml)
 
 -- | A newtype wrapper around a 'Text' whose 'ToMarkup' instance converts newlines to HTML @\<br>@ tags.
--- 
+--
 -- (When text is entered into a @\<textarea>@, newline characters are used to separate lines.
 -- If this text is then placed verbatim into HTML, the lines won't be separated, thus the need for replacing with @\<br>@ tags).
 -- If you don't need this functionality, simply use 'unTextarea' to access the raw text.
 newtype Textarea = Textarea { unTextarea :: Text }
-    deriving (Show, Read, Eq, PersistField, Ord, ToJSON, FromJSON)
+    deriving (Show, Read, Eq, PersistField, Ord, ToJSON, FromJSON, IsString)
 instance PersistFieldSql Textarea where
     sqlType _ = SqlString
 instance ToHtml Textarea where
@@ -341,7 +354,7 @@ timeParser = do
         if i < 0 || i >= 60
             then fail $ show $ msg $ pack xy
             else return $ fromIntegral (i :: Int)
-            
+
 -- | Creates an input with @type="email"@. Yesod will validate the email's correctness according to RFC5322 and canonicalize it by removing comments and whitespace (see "Text.Email.Validate").
 emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
 emailField = Field
@@ -359,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 $
@@ -424,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)
@@ -443,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)
@@ -509,31 +533,58 @@ 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.
 --
 -- If this field is optional, the first radio button is labeled "\<None>", the second \"Yes" and the third \"No".
 --
--- If this field is required, the first radio button is labeled \"Yes" and the second \"No". 
+-- If this field is required, the first radio button is labeled \"Yes" and the second \"No".
 --
 -- (Exact label titles will depend on localization).
 boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
@@ -567,7 +618,7 @@ $newline never
       t -> Left $ SomeMessage $ MsgInvalidBool t
     showVal = either (\_ -> False)
 
--- | Creates an input with @type="checkbox"@. 
+-- | Creates an input with @type="checkbox"@.
 --   While the default @'boolField'@ implements a radio button so you
 --   can differentiate between an empty response (@Nothing@) and a no
 --   response (@Just False@), this simpler checkbox field returns an empty
@@ -595,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) = 
+    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
@@ -612,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
 
@@ -634,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]
@@ -689,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
@@ -727,32 +827,39 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
         , optionExternalValue = toPathPiece key
         }) pairs
 
+-- |
+-- 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
         :: (Eq a, RenderMessage site FormMessage)
-        => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ())
+        => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()) -- ^ Outermost part of the field
-        -> (Text -> Text -> Bool -> WidgetFor site ())
+        -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional
-        -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ())
+        -> (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
-    render _ (Left _) = ""
+    render _ (Left x) = x
     render opts (Right a) = maybe "" optionExternalValue $ listToMaybe $ filter ((== a) . optionInternalValue) opts
     selectParser _ [] = Right Nothing
     selectParser opts (s:_) = case s of
@@ -761,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
@@ -857,11 +972,52 @@ 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.
--- 
+--
 -- 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/Functions.hs

@@ -18,10 +18,13 @@ module Yesod.Form.Functions
     , wFormToMForm
       -- * Fields to Forms
     , wreq
+    , wreqMsg
     , wopt
     , mreq
+    , mreqMsg
     , mopt
     , areq
+    , areqMsg
     , aopt
       -- * Run a form
     , runFormPost
@@ -51,10 +54,13 @@ module Yesod.Form.Functions
     , parseHelper
     , parseHelperGen
     , convertField
+    , addClass
+    , removeClass
     ) where
 
 import Yesod.Form.Types
 import Data.Text (Text, pack)
+import qualified Data.Text as T
 import Control.Arrow (second)
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST)
@@ -120,7 +126,23 @@ wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe a             -- ^ optional default value
      -> WForm m (FormResult a)
-wreq f fs = mFormToWForm . mreq f fs
+wreq f fs = wreqMsg f fs MsgValueRequired
+
+-- | Same as @wreq@ but with your own message to be rendered in case the value
+-- is not provided.
+--
+-- This is useful when you have several required fields on the page and you
+-- want to differentiate between which fields were left blank. Otherwise the
+-- user sees "Value is required" multiple times, which is ambiguous.
+--
+-- @since 1.6.7
+wreqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+        => Field m a           -- ^ form field
+        -> FieldSettings site  -- ^ settings for this field
+        -> msg                 -- ^ message to use in case value is Nothing
+        -> Maybe a             -- ^ optional default value
+        -> WForm m (FormResult a)
+wreqMsg f fs msg = mFormToWForm . mreqMsg f fs msg
 
 -- | Converts a form field into monadic form 'WForm'. This field is optional,
 -- i.e.  if filled in, it returns 'Just a', if left empty, it returns
@@ -170,7 +192,24 @@ mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe a             -- ^ optional default value
      -> MForm m (FormResult a, FieldView site)
-mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
+mreq field fs mdef = mreqMsg field fs MsgValueRequired mdef
+
+-- | Same as @mreq@ but with your own message to be rendered in case the value
+-- is not provided.
+--
+-- This is useful when you have several required fields on the page and you
+-- want to differentiate between which fields were left blank. Otherwise the
+-- user sees "Value is required" multiple times, which is ambiguous.
+--
+-- @since 1.6.6
+mreqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+        => Field m a           -- ^ form field
+        -> FieldSettings site  -- ^ settings for this field
+        -> msg                 -- ^ Message to use in case value is Nothing
+        -> Maybe a             -- ^ optional default value
+        -> MForm m (FormResult a, FieldView site)
+mreqMsg field fs msg mdef = mhelper field fs mdef formFailure FormSuccess True
+  where formFailure m l = FormFailure [renderMessage m l msg]
 
 -- | Converts a form field into monadic form. This field is optional, i.e.
 -- if filled in, it returns 'Just a', if left empty, it returns 'Nothing'.
@@ -226,11 +265,27 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
 
 -- | Applicative equivalent of 'mreq'.
 areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
-     => Field m a
+     => Field m a           -- ^ form field
-     -> FieldSettings site
+     -> FieldSettings site  -- ^ settings for this field
-     -> Maybe a
+     -> Maybe a             -- ^ optional default value
      -> AForm m a
-areq a b = formToAForm . liftM (second return) . mreq a b
+areq f fs = areqMsg f fs MsgValueRequired
+
+-- | Same as @areq@ but with your own message to be rendered in case the value
+-- is not provided.
+--
+-- This is useful when you have several required fields on the page and you
+-- want to differentiate between which fields were left blank. Otherwise the
+-- user sees "Value is required" multiple times, which is ambiguous.
+--
+-- @since 1.6.7
+areqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+        => Field m a           -- ^ form field
+        -> FieldSettings site  -- ^ settings for this field
+        -> msg                 -- ^ message to use in case value is Nothing
+        -> Maybe a             -- ^ optional default value
+        -> AForm m a
+areqMsg f fs msg = formToAForm . liftM (second return) . mreqMsg f fs msg
 
 -- | Applicative equivalent of 'mopt'.
 aopt :: MonadHandler m
@@ -615,3 +670,33 @@ convertField to from (Field fParse fView fEnctype) = let
   fParse' ts = fmap (fmap (fmap to)) . fParse ts
   fView' ti tn at ei = fView ti tn at (fmap from ei)
   in Field fParse' fView' fEnctype
+
+-- | Removes a CSS class from the 'fsAttrs' in a 'FieldSettings'.
+--
+-- ==== __Examples__
+--
+-- >>> removeClass "form-control" [("class","form-control login-form"),("id","home-login")]
+-- [("class","  login-form"),("id","home-login")]
+--
+-- @since 1.6.2
+removeClass :: Text -- ^ The class to remove
+            -> [(Text, Text)] -- ^ List of existing 'fsAttrs'
+            -> [(Text, Text)]
+removeClass _     []                    = []
+removeClass klass (("class", old):rest) = ("class", T.replace klass " " old) : rest
+removeClass klass (other         :rest) = other : removeClass klass rest
+
+-- | Adds a CSS class to the 'fsAttrs' in a 'FieldSettings'.
+--
+-- ==== __Examples__
+--
+-- >>> addClass "login-form" [("class", "form-control"), ("id", "home-login")]
+-- [("class","form-control login-form"),("id","home-login")]
+--
+-- @since 1.6.2
+addClass :: Text -- ^ The class to add
+         -> [(Text, Text)] -- ^ List of existing 'fsAttrs'
+         -> [(Text, Text)]
+addClass klass []                    = [("class", klass)]
+addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
+addClass klass (other         :rest) = other : addClass klass rest

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