Actually export the new options (#1825)

* actually export the new options

* bump version number, update changelog

.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,174 +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.4.4 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7
-    compiler: ": #GHC 8.4.4"
-    addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
-  - env: BUILD=cabal GHCVER=8.6.3 CABALVER=2.4 HAPPYVER=1.19.5 ALEXVER=3.1.7
-    compiler: ": #GHC 8.6.3"
-    addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.3,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-12"
-    compiler: ": #stack 8.4.4"
-    addons: {apt: {packages: [libgmp-dev]}}
-
-  - env: BUILD=stack ARGS="--resolver lts-13"
-    compiler: ": #stack 8.6.3"
-    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
-
-  - env: BUILD=stack ARGS="--resolver lts-12"
-    compiler: ": #stack 8.4.4 osx"
-    os: osx
-
-  - env: BUILD=stack ARGS="--resolver lts-13"
-    compiler: ": #stack 8.6.3 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://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin
-  else
-    travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | 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
-
-
-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 --recursive http://github.com/yesodweb/persistent
-git clone --recursive http://github.com/yesodweb/wai
-git clone --recursive http://github.com/yesodweb/yesod
+git clone --recurse-submodules http://github.com/yesodweb/shakespeare
+git clone --recurse-submodules http://github.com/yesodweb/persistent
+git clone --recurse-submodules http://github.com/yesodweb/wai
+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,15 +0,0 @@
-# cache:
-#   - '%AppData%\stack'
-
-install:
-  - curl -sS -ostack.zip -L https://get.haskellstack.org/stable/windows-i386.zip
-  - 7z x stack.zip stack.exe
-  - stack setup > nul
-
-build: off
-
-build_script:
-  - stack --no-terminal test --no-run-tests
-
-test_script:
-  - stack --jobs 1 --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.

stack.yaml

@@ -1,10 +1,11 @@
-resolver: lts-13.4
+resolver: lts-18.3
 packages:
 - ./yesod-core
 - ./yesod-static
 - ./yesod-persistent
 - ./yesod-newsfeed
 - ./yesod-form
+- ./yesod-form-multi
 - ./yesod-auth
 - ./yesod-auth-oauth
 - ./yesod-sitemap
@@ -13,3 +14,6 @@ packages:
 - ./yesod
 - ./yesod-eventsource
 - ./yesod-websockets
+
+extra-deps:
+- attoparsec-aeson-2.1.0.0

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,17 @@
+# 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)

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

@@ -1,10 +1,9 @@
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 module Yesod.Auth.OAuth
     ( authOAuth
     , oauthUrl
@@ -15,8 +14,13 @@ module Yesod.Auth.OAuth
     , tumblrUrl
     , module Web.Authenticate.OAuth
     ) where
+import           Control.Applicative      as A ((<$>), (<*>))
 import           Control.Arrow            ((***))
-import           RIO
+import           UnliftIO.Exception
+import           Control.Monad.IO.Class
+import           Data.ByteString          (ByteString)
+import           Data.Maybe
+import           Data.Text                (Text)
 import qualified Data.Text                as T
 import           Data.Text.Encoding       (decodeUtf8With, encodeUtf8)
 import           Data.Text.Encoding.Error (lenientDecode)
@@ -27,7 +31,7 @@ import           Yesod.Core
 
 data YesodOAuthException = CredentialError String Credential
                          | SessionError String
-                           deriving (Show, Typeable)
+                           deriving Show
 
 instance Exception YesodOAuthException
 
@@ -50,7 +54,7 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
     dispatch
       :: Text
       -> [Text]
-      -> SubHandlerFor Auth master TypedContent
+      -> AuthHandler master TypedContent
     dispatch "GET" ["forward"] = do
         render <- getUrlRender
         tm <- getRouteToParent
@@ -73,8 +77,8 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
                                 ]
           else do
             (verifier, oaTok) <-
-                runInputGet $ (,) <$> ireq textField "oauth_verifier"
-                                  <*> ireq textField "oauth_token"
+                runInputGet $ (,) A.<$> ireq textField "oauth_verifier"
+                                  A.<*> ireq textField "oauth_token"
             return $ Credential [ ("oauth_verifier", encodeUtf8 verifier)
                                 , ("oauth_token", encodeUtf8 oaTok)
                                 , ("oauth_token_secret", encodeUtf8 tokSec)

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

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

yesod-auth/ChangeLog.md

@@ -1,5 +1,62 @@
 # 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/)

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

@@ -6,17 +6,14 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Yesod.Auth
     ( -- * Subsite
       Auth
     , AuthRoute
-    , AuthHandler
     , Route (..)
     , AuthPlugin (..)
     , getAuth
@@ -40,6 +37,9 @@ module Yesod.Auth
     , requireAuth
       -- * Exception
     , AuthException (..)
+      -- * Helper
+    , MonadAuthHandler
+    , AuthHandler
       -- * Internal
     , credsKey
     , provideJsonMessage
@@ -47,11 +47,11 @@ module Yesod.Auth
     , asHtml
     ) where
 
-import RIO
+import Control.Monad                 (when)
 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)
@@ -73,11 +73,13 @@ import Control.Exception (Exception)
 import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
 import qualified Control.Monad.Trans.Writer    as Writer
 import Control.Monad (void)
-
-type AuthHandler site = SubHandlerFor Auth site
+import Data.Kind (Type)
 
 type AuthRoute = Route Auth
 
+type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
+type AuthHandler master a = forall m. MonadAuthHandler master m => m a
+
 type Method = Text
 type Piece = Text
 
@@ -91,7 +93,7 @@ data AuthenticationResult master
 
 data AuthPlugin master = AuthPlugin
     { apName :: Text
-    , apDispatch :: Method -> [Piece] -> SubHandlerFor Auth master TypedContent
+    , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
     , apLogin :: (Route Auth -> Route master) -> WidgetFor master ()
     }
 
@@ -109,7 +111,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     type AuthId master
 
     -- | specify the layout. Uses defaultLayout by default
-    authLayout :: (HasHandlerData env, HandlerSite env ~ master) => WidgetFor master () -> RIO env Html
+    authLayout :: (MonadHandler m, HandlerSite m ~ master) => WidgetFor master () -> m Html
     authLayout = liftHandler . defaultLayout
 
     -- | Default destination on successful login, if no other
@@ -125,7 +127,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- Default implementation is in terms of @'getAuthId'@
     --
     -- @since: 1.4.4
-    authenticate :: (HasHandlerData env, HandlerSite env ~ master) => Creds master -> RIO env (AuthenticationResult master)
+    authenticate :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (AuthenticationResult master)
     authenticate creds = do
         muid <- getAuthId creds
 
@@ -135,7 +137,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     --
     -- Default implementation is in terms of @'authenticate'@
     --
-    getAuthId :: (HasHandlerData env, HandlerSite env ~ master) => Creds master -> RIO env (Maybe (AuthId master))
+    getAuthId :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (Maybe (AuthId master))
     getAuthId creds = do
         auth <- authenticate creds
 
@@ -165,9 +167,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- >             lift $ redirect HomeR   -- or any other Handler code you want
     -- >         defaultLoginHandler
     --
-    loginHandler
-      :: (HasHandlerData env, SubHandlerSite env ~ Auth, HandlerSite env ~ master)
-      => RIO env Html
+    loginHandler :: AuthHandler master Html
     loginHandler = defaultLoginHandler
 
     -- | Used for i18n of messages provided by this package.
@@ -193,16 +193,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- type. This allows backends to reuse persistent connections. If none of
     -- the backends you're using use HTTP connections, you can safely return
     -- @error \"authHttpManager\"@ here.
-    authHttpManager :: (HasHandlerData env, HandlerSite env ~ master) => RIO env Manager
+    authHttpManager :: (MonadHandler m, HandlerSite m ~ master) => m Manager
     authHttpManager = liftIO getGlobalManager
 
     -- | Called on a successful login. By default, calls
     -- @addMessageI "success" NowLoggedIn@.
-    onLogin :: (HasHandlerData env, master ~ HandlerSite env) => RIO env ()
+    onLogin :: (MonadHandler m, master ~ HandlerSite m) => m ()
     onLogin = addMessageI "success" Msg.NowLoggedIn
 
     -- | Called on logout. By default, does nothing
-    onLogout :: (HasHandlerData env, master ~ HandlerSite env) => RIO env ()
+    onLogout :: (MonadHandler m, master ~ HandlerSite m) => m ()
     onLogout = return ()
 
     -- | Retrieves user credentials, if user is authenticated.
@@ -214,20 +214,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- other than a browser.
     --
     -- @since 1.2.0
-    maybeAuthId :: (HasHandlerData env, master ~ HandlerSite env) => RIO env (Maybe (AuthId master))
+    maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master))
 
     default maybeAuthId
-        :: (HasHandlerData env, master ~ HandlerSite env, YesodAuthPersist master, Typeable (AuthEntity master))
-        => RIO env (Maybe (AuthId master))
+        :: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master))
+        => m (Maybe (AuthId master))
     maybeAuthId = defaultMaybeAuthId
 
     -- | Called on login error for HTTP requests. By default, calls
     -- @addMessage@ with "error" as status and redirects to @dest@.
-    onErrorHtml
-      :: (HasHandlerData env, HandlerSite env ~ master)
-      => Route master
-      -> Text
-      -> RIO env Html
+    onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html
     onErrorHtml dest msg = do
         addMessage "error" $ toHtml msg
         fmap asHtml $ redirect dest
@@ -238,10 +234,10 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     --  The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request.
     --  This is an experimental API that is not broadly used throughout the yesod-auth code base
     runHttpRequest
-      :: (HasHandlerData env, HandlerSite env ~ master)
+      :: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m)
       => Request
-      -> (Response BodyReader -> RIO env a)
-      -> RIO env a
+      -> (Response BodyReader -> m a)
+      -> m a
     runHttpRequest req inner = do
       man <- authHttpManager
       withRunInIO $ \run -> withResponse req man $ run . inner
@@ -264,8 +260,8 @@ credsKey = "_ID"
 --
 -- @since 1.1.2
 defaultMaybeAuthId
-    :: (HasHandlerData env, HandlerSite env ~ master, YesodAuthPersist master, Typeable (AuthEntity master))
-    => RIO env (Maybe (AuthId master))
+    :: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master))
+    => m (Maybe (AuthId master))
 defaultMaybeAuthId = runMaybeT $ do
     s   <- MaybeT $ lookupSession credsKey
     aid <- MaybeT $ return $ fromPathPiece s
@@ -273,13 +269,13 @@ defaultMaybeAuthId = runMaybeT $ do
     return aid
 
 cachedAuth
-    :: ( HasHandlerData env
+    :: ( MonadHandler m
        , YesodAuthPersist master
        , Typeable (AuthEntity master)
-       , HandlerSite env ~ master
+       , HandlerSite m ~ master
        )
     => AuthId master
-    -> RIO env (Maybe (AuthEntity master))
+    -> m (Maybe (AuthEntity master))
 cachedAuth
     = fmap unCachedMaybeAuth
     . cached
@@ -293,9 +289,7 @@ cachedAuth
 -- wraps the result in 'authLayout'.  See 'loginHandler' for more details.
 --
 -- @since 1.4.9
-defaultLoginHandler
-  :: (HasHandlerData env, SubHandlerSite env ~ Auth, YesodAuth (HandlerSite env))
-  => RIO env Html
+defaultLoginHandler :: AuthHandler master Html
 defaultLoginHandler = do
     tp <- getRouteToParent
     authLayout $ do
@@ -303,21 +297,21 @@ defaultLoginHandler = do
         master <- getYesod
         mapM_ (flip apLogin tp) (authPlugins master)
 
+
 loginErrorMessageI
-  :: (HasHandlerData env, SubHandlerSite env ~ Auth, YesodAuth (HandlerSite env))
-  => Route Auth
+  :: Route Auth
   -> AuthMessage
-  -> RIO env TypedContent
+  -> AuthHandler master TypedContent
 loginErrorMessageI dest msg = do
   toParent <- getRouteToParent
   loginErrorMessageMasterI (toParent dest) msg
 
 
 loginErrorMessageMasterI
-  :: (HasHandlerData env, HandlerSite env ~ master, YesodAuth master)
+  :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)
   => Route master
   -> AuthMessage
-  -> RIO env TypedContent
+  -> m TypedContent
 loginErrorMessageMasterI dest msg = do
   mr <- getMessageRender
   loginErrorMessage dest (mr msg)
@@ -325,28 +319,28 @@ loginErrorMessageMasterI dest msg = do
 -- | For HTML, set the message and redirect to the route.
 -- For JSON, send the message and a 401 status
 loginErrorMessage
-         :: (HasHandlerData env, YesodAuth (HandlerSite env))
-         => Route (HandlerSite env)
+         :: (MonadHandler m, YesodAuth (HandlerSite m))
+         => Route (HandlerSite m)
          -> Text
-         -> RIO env TypedContent
+         -> m TypedContent
 loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
 
 messageJson401
-  :: HasHandlerData env
+  :: MonadHandler m
   => Text
-  -> RIO env Html
-  -> RIO env TypedContent
+  -> m Html
+  -> m TypedContent
 messageJson401 = messageJsonStatus unauthorized401
 
-messageJson500 :: HasHandlerData env => Text -> RIO env Html -> RIO env TypedContent
+messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent
 messageJson500 = messageJsonStatus internalServerError500
 
 messageJsonStatus
-  :: HasHandlerData env
+  :: MonadHandler m
   => Status
   -> Text
-  -> RIO env Html
-  -> RIO env TypedContent
+  -> m Html
+  -> m TypedContent
 messageJsonStatus status msg html = selectRep $ do
     provideRep html
     provideRep $ do
@@ -359,9 +353,9 @@ provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
 
 
 setCredsRedirect
-  :: (HasHandlerData env, YesodAuth (HandlerSite env))
-  => Creds (HandlerSite env) -- ^ new credentials
-  -> RIO env TypedContent
+  :: (MonadHandler m, YesodAuth (HandlerSite m))
+  => Creds (HandlerSite m) -- ^ new credentials
+  -> m TypedContent
 setCredsRedirect creds = do
     y    <- getYesod
     auth <- authenticate creds
@@ -384,7 +378,7 @@ setCredsRedirect creds = do
                 Just ar -> loginErrorMessageMasterI ar msg
 
         ServerError msg -> do
-            logError $ display msg
+            $(logError) msg
 
             case authRoute y of
                 Nothing -> do
@@ -400,10 +394,10 @@ setCredsRedirect creds = do
         return $ renderAuthMessage master langs msg
 
 -- | Sets user credentials for the session after checking them with authentication backends.
-setCreds :: (HasHandlerData env, YesodAuth (HandlerSite env))
+setCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
          => Bool                  -- ^ if HTTP redirects should be done
-         -> Creds (HandlerSite env) -- ^ new credentials
-         -> RIO env ()
+         -> Creds (HandlerSite m) -- ^ new credentials
+         -> m ()
 setCreds doRedirects creds =
     if doRedirects
       then void $ setCredsRedirect creds
@@ -414,10 +408,10 @@ setCreds doRedirects creds =
 
 -- | same as defaultLayoutJson, but uses authLayout
 authLayoutJson
-  :: (ToJSON j, HasHandlerData env, YesodAuth (HandlerSite env))
-  => WidgetFor (HandlerSite env) ()  -- ^ HTML
-  -> RIO env j  -- ^ JSON
-  -> RIO env TypedContent
+  :: (ToJSON j, MonadAuthHandler master m)
+  => WidgetFor master ()  -- ^ HTML
+  -> m j  -- ^ JSON
+  -> m TypedContent
 authLayoutJson w json = selectRep $ do
     provideRep $ authLayout w
     provideRep $ fmap toJSON json
@@ -425,17 +419,23 @@ authLayoutJson w json = selectRep $ do
 -- | Clears current user credentials for the session.
 --
 -- @since 1.1.7
-clearCreds :: (HasHandlerData env, YesodAuth (HandlerSite env))
-           => Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-           -> RIO env ()
+clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
+           => Bool -- ^ if HTTP, redirect to 'logoutDest'
+           -> m ()
 clearCreds doRedirects = do
-    y <- getYesod
     onLogout
     deleteSession credsKey
-    when doRedirects $ do
-        redirectUltDest $ logoutDest y
+    y  <- getYesod
+    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 :: (YesodAuth (HandlerSite env), HasHandlerData env) => RIO env TypedContent
+getCheckR :: AuthHandler master TypedContent
 getCheckR = do
     creds <- maybeAuthId
     authLayoutJson (do
@@ -452,31 +452,27 @@ $nothing
     <p>Not logged in.
 |]
     jsonCreds creds =
-        Object $ Map.fromList
+        toJSON $ Map.fromList
             [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
             ]
 
-setUltDestReferer' :: (HasHandlerData env, YesodAuth (HandlerSite env)) => RIO env ()
+setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m ()
 setUltDestReferer' = do
     master <- getYesod
     when (redirectToReferer master) setUltDestReferer
 
-getLoginR :: (HasHandlerData env, YesodAuth (HandlerSite env), SubHandlerSite env ~ Auth) => RIO env Html
+getLoginR :: AuthHandler master Html
 getLoginR = setUltDestReferer' >> loginHandler
 
-getLogoutR :: (HasHandlerData env, YesodAuth (HandlerSite env), SubHandlerSite env ~ Auth) => RIO env ()
+getLogoutR :: AuthHandler master ()
 getLogoutR = do
   tp <- getRouteToParent
   setUltDestReferer' >> redirectToPost (tp LogoutR)
 
-postLogoutR :: (HasHandlerData env, YesodAuth (HandlerSite env)) => RIO env ()
+postLogoutR :: AuthHandler master ()
 postLogoutR = clearCreds True
 
-handlePluginR
-  :: YesodAuth site
-  => Text
-  -> [Text]
-  -> SubHandlerFor Auth site TypedContent
+handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
 handlePluginR plugin pieces = do
     master <- getYesod
     env <- waiRequest
@@ -495,9 +491,9 @@ maybeAuth :: ( YesodAuthPersist master
              , Key val ~ AuthId master
              , PersistEntity val
              , Typeable val
-             , HasHandlerData env
-             , HandlerSite env ~ master
-             ) => RIO env (Maybe (Entity val))
+             , MonadHandler m
+             , HandlerSite m ~ master
+             ) => m (Maybe (Entity val))
 maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
 
 -- | Similar to 'maybeAuth', but doesn’t assume that you are using a
@@ -507,10 +503,10 @@ maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
 maybeAuthPair
   :: ( YesodAuthPersist master
      , Typeable (AuthEntity master)
-     , HasHandlerData env
-     , HandlerSite env ~ master
+     , MonadHandler m
+     , HandlerSite m ~ master
      )
-  => RIO env (Maybe (AuthId master, AuthEntity master))
+  => m (Maybe (AuthId master, AuthEntity master))
 maybeAuthPair = runMaybeT $ do
     aid <- MaybeT maybeAuthId
     ae  <- MaybeT $ cachedAuth aid
@@ -518,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
@@ -538,24 +533,21 @@ 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
-      :: (HasHandlerData env, HandlerSite env ~ master)
-      => AuthId master
-      -> RIO env (Maybe (AuthEntity master))
+    getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)
+                  => AuthId master -> m (Maybe (AuthEntity master))
 
     default getAuthEntity
         :: ( YesodPersistBackend master ~ backend
            , PersistRecordBackend (AuthEntity master) backend
            , Key (AuthEntity master) ~ AuthId master
            , PersistStore backend
-           , HasHandlerData env
-           , HandlerSite env ~ master
+           , MonadHandler m
+           , HandlerSite m ~ master
            )
-        => AuthId master
-        -> RIO env (Maybe (AuthEntity master))
+        => AuthId master -> m (Maybe (AuthEntity master))
     getAuthEntity = liftHandler . runDB . get
 
 
@@ -566,7 +558,7 @@ type instance KeyEntity (Key x) = x
 -- authenticated or responds with error 401 if this is an API client (expecting JSON).
 --
 -- @since 1.1.0
-requireAuthId :: (HasHandlerData env, YesodAuth (HandlerSite env)) => RIO env (AuthId (HandlerSite env))
+requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m))
 requireAuthId = maybeAuthId >>= maybe handleAuthLack return
 
 -- | Similar to 'maybeAuth', but redirects to a login page if user is not
@@ -578,9 +570,9 @@ requireAuth :: ( YesodAuthPersist master
                , Key val ~ AuthId master
                , PersistEntity val
                , Typeable val
-               , HasHandlerData env
-               , HandlerSite env ~ master
-               ) => RIO env (Entity val)
+               , MonadHandler m
+               , HandlerSite m ~ master
+               ) => m (Entity val)
 requireAuth = maybeAuth >>= maybe handleAuthLack return
 
 -- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
@@ -590,18 +582,18 @@ requireAuth = maybeAuth >>= maybe handleAuthLack return
 requireAuthPair
   :: ( YesodAuthPersist master
      , Typeable (AuthEntity master)
-     , HasHandlerData env
-     , HandlerSite env ~ master
+     , MonadHandler m
+     , HandlerSite m ~ master
      )
-  => RIO env (AuthId master, AuthEntity master)
+  => m (AuthId master, AuthEntity master)
 requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return
 
-handleAuthLack :: (YesodAuth (HandlerSite env), HasHandlerData env) => RIO env a
+handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
 handleAuthLack = do
     aj <- acceptsJson
     if aj then notAuthenticated else redirectLogin
 
-redirectLogin :: (YesodAuth (HandlerSite env), HasHandlerData env) => RIO env a
+redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
 redirectLogin = do
     y <- getYesod
     when (redirectToCurrent y) setUltDestCurrent
@@ -613,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/BrowserId.hs

@@ -0,0 +1,170 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RecordWildCards #-}
+-- | NOTE: Mozilla Persona will be shut down by the end of 2016, therefore this
+-- module is no longer recommended for use.
+module Yesod.Auth.BrowserId
+    {-# DEPRECATED "Mozilla Persona will be shut down by the end of 2016" #-}
+    ( authBrowserId
+    , createOnClick, createOnClickOverride
+    , def
+    , BrowserIdSettings
+    , bisAudience
+    , bisLazyLoad
+    , forwardUrl
+    ) where
+
+import Yesod.Auth
+import Web.Authenticate.BrowserId
+import Data.Text (Text)
+import Yesod.Core
+import qualified Data.Text as T
+import Data.Maybe (fromMaybe)
+import Control.Monad (when, unless)
+import Text.Julius (rawJS)
+import Network.URI (uriPath, parseURI)
+import Data.FileEmbed (embedFile)
+import Data.ByteString (ByteString)
+import Data.Default
+
+pid :: Text
+pid = "browserid"
+
+forwardUrl :: AuthRoute
+forwardUrl = PluginR pid []
+
+complete :: AuthRoute
+complete = forwardUrl
+
+-- | A settings type for various configuration options relevant to BrowserID.
+--
+-- See: <http://www.yesodweb.com/book/settings-types>
+--
+-- Since 1.2.0
+data BrowserIdSettings = BrowserIdSettings
+    { bisAudience :: Maybe Text
+    -- ^ BrowserID audience value. If @Nothing@, will be extracted based on the
+    -- approot.
+    --
+    -- Default: @Nothing@
+    --
+    -- Since 1.2.0
+    , bisLazyLoad :: Bool
+    -- ^ Use asynchronous Javascript loading for the BrowserID JS file.
+    --
+    -- Default: @True@.
+    --
+    -- Since 1.2.0
+    }
+
+instance Default BrowserIdSettings where
+    def = BrowserIdSettings
+        { bisAudience = Nothing
+        , bisLazyLoad = True
+        }
+
+authBrowserId :: YesodAuth m => BrowserIdSettings -> AuthPlugin m
+authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
+    { apName = pid
+    , apDispatch = \m ps ->
+        case (m, ps) of
+            ("GET", [assertion]) -> do
+                audience <-
+                    case bisAudience of
+                        Just a -> return a
+                        Nothing -> do
+                            r <- getUrlRender
+                            tm <- getRouteToParent
+                            return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
+                manager <- authHttpManager
+                memail <- checkAssertion audience assertion manager
+                case memail of
+                    Nothing -> do
+                      $logErrorS "yesod-auth" "BrowserID assertion failure"
+                      tm <- getRouteToParent
+                      loginErrorMessage (tm LoginR) "BrowserID login error."
+                    Just email -> setCredsRedirect Creds
+                        { credsPlugin = pid
+                        , credsIdent = email
+                        , credsExtra = []
+                        }
+            ("GET", ["static", "sign-in.png"]) -> sendResponse
+                ( "image/png" :: ByteString
+                , toContent $(embedFile "persona_sign_in_blue.png")
+                )
+            (_, []) -> badMethod
+            _ -> notFound
+    , apLogin = \toMaster -> do
+        onclick <- createOnClick bis toMaster
+
+        autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
+        when autologin $ toWidget [julius|#{rawJS onclick}();|]
+
+        toWidget [hamlet|
+$newline never
+<p>
+    <a href="javascript:#{onclick}()">
+        <img src=@{toMaster loginIcon}>
+|]
+    }
+  where
+    loginIcon = PluginR pid ["static", "sign-in.png"]
+    stripScheme t = fromMaybe t $ T.stripPrefix "//" $ snd $ T.breakOn "//" t
+
+-- | Generates a function to handle on-click events, and returns that function
+-- name.
+createOnClickOverride :: BrowserIdSettings
+              -> (Route Auth -> Route master)
+              -> Maybe (Route master)
+              -> WidgetFor master Text
+createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
+    unless bisLazyLoad $ addScriptRemote browserIdJs
+    onclick <- newIdent
+    render <- getUrlRender
+    let login = toJSON $ getPath $ render loginRoute -- (toMaster LoginR)
+        loginRoute = maybe (toMaster LoginR) id mOnRegistration
+    toWidget [julius|
+        function #{rawJS onclick}() {
+            if (navigator.id) {
+                navigator.id.watch({
+                    onlogin: function (assertion) {
+                        if (assertion) {
+                            document.location = "@{toMaster complete}/" + assertion;
+                        }
+                    },
+                    onlogout: function () {}
+                });
+                navigator.id.request({
+                    returnTo: #{login} + "?autologin=true"
+                });
+            }
+            else {
+                alert("Loading, please try again");
+            }
+        }
+    |]
+    when bisLazyLoad $ toWidget [julius|
+        (function(){
+            var bid = document.createElement("script");
+            bid.async = true;
+            bid.src = #{toJSON browserIdJs};
+            var s = document.getElementsByTagName('script')[0];
+            s.parentNode.insertBefore(bid, s);
+        })();
+    |]
+
+    autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
+    when autologin $ toWidget [julius|#{rawJS onclick}();|]
+    return onclick
+  where
+    getPath t = fromMaybe t $ do
+        uri <- parseURI $ T.unpack t
+        return $ T.pack $ uriPath uri
+
+-- | Generates a function to handle on-click events, and returns that function
+-- name.
+createOnClick :: BrowserIdSettings
+              -> (Route Auth -> Route master)
+              -> WidgetFor master Text
+createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing

yesod-auth/Yesod/Auth/Dummy.hs

@@ -1,25 +1,67 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE QuasiQuotes         #-}
+{-# 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
--- testing.
+-- their identifier. This is not intended for real world use, just for
+-- 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 Yesod.Form (runInputPost, textField, ireq)
-import Yesod.Core
+import           Data.Aeson.Types (Parser, Result (..))
+import qualified Data.Aeson.Types as A (parseEither, withObject)
+import           Data.Text        (Text)
+import           Yesod.Auth
+import           Yesod.Core
+import           Yesod.Form       (ireq, runInputPost, textField)
+
+identParser :: Value -> Parser Text
+identParser = A.withObject "Ident" (.: "ident")
 
 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"
-        setCredsRedirect $ Creds "dummy" ident []
+        (jsonResult :: Result Value) <- parseCheckJsonBody
+        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,16 +31,16 @@
 -- = 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
@@ -49,9 +49,9 @@
 --                      "password": "myStrongPassword" (optional)
 --                  }
 -- @
--- 
+--
 --     * Forgot password
---  
+--
 -- @
 --       Endpoint: \/auth\/page\/email\/forgot-password
 --       Method: POST
@@ -59,16 +59,16 @@
 -- @
 --
 --     * Login
---  
+--
 -- @
 --       Endpoint: \/auth\/page\/email\/login
 --       Method: POST
---       JSON Data: { 
+--       JSON Data: {
 --                      "email": "myemail@domain.com",
 --                      "password": "myStrongPassword"
 --                  }
 -- @
--- 
+--
 --     * Set new password
 --
 -- @
@@ -113,30 +113,34 @@ module Yesod.Auth.Email
     , defaultRegisterHandler
     , defaultForgotPasswordHandler
     , defaultSetPasswordHandler
+     -- * Default helpers
+    , defaultRegisterHelper
     ) where
 
-import           Yesod.Auth
-import qualified Yesod.Auth.Message       as Msg
-import           Yesod.Core
-import           Yesod.Form
-import qualified Yesod.Auth.Util.PasswordStore as PS
-import           Control.Applicative      ((<$>), (<*>))
-import qualified Crypto.Hash              as H
-import qualified Crypto.Nonce             as Nonce
-import           Data.ByteString.Base16   as B16
-import           Data.Text                (Text)
-import qualified Data.Text                as TS
-import qualified Data.Text                as T
-import           Data.Text.Encoding       (decodeUtf8With, encodeUtf8)
-import qualified Data.Text.Encoding       as TE
-import           Data.Text.Encoding.Error (lenientDecode)
-import           Data.Time                (addUTCTime, getCurrentTime)
-import           Safe                     (readMay)
-import           System.IO.Unsafe         (unsafePerformIO)
+import           Control.Applicative           ((<$>), (<*>))
+import qualified Crypto.Hash                   as H
+import qualified Crypto.Nonce                  as Nonce
+import           Data.Aeson.Types              (Parser, Result (..), parseMaybe,
+                                                withObject, (.:?))
+import           Data.ByteArray                (convert)
+import           Data.ByteString.Base16        as B16
+import           Data.Maybe                    (isJust)
+import           Data.Text                     (Text)
+import qualified Data.Text                     as T
+import qualified Data.Text                     as TS
+import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8)
+import qualified Data.Text.Encoding            as TE
+import           Data.Text.Encoding.Error      (lenientDecode)
+import           Data.Time                     (addUTCTime, getCurrentTime)
+import           Safe                          (readMay)
+import           System.IO.Unsafe              (unsafePerformIO)
 import qualified Text.Email.Validate
-import           Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
-import           Data.Maybe (isJust)
-import Data.ByteArray (convert)
+import           Yesod.Auth
+import qualified Yesod.Auth.Message            as Msg
+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"]
@@ -210,6 +214,18 @@ class ( YesodAuth site
     -- @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
@@ -226,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.
     --
@@ -327,7 +343,7 @@ class ( YesodAuth site
     -- used.
     --
     -- @since 1.6.4
-    emailPreviouslyRegisteredResponse :: Text -> Maybe (AuthHandler site TypedContent)
+    emailPreviouslyRegisteredResponse :: MonadAuthHandler site m => Text -> Maybe (m TypedContent)
     emailPreviouslyRegisteredResponse _ = Nothing
 
     -- | Additional normalization of email addresses, besides standard canonicalization.
@@ -376,8 +392,8 @@ class ( YesodAuth site
     -- Default: 'defaultSetPasswordHandler'.
     --
     -- @since: 1.2.6
-    setPasswordHandler
-      :: Bool
+    setPasswordHandler ::
+         Bool
          -- ^ Whether the old password is needed.  If @True@, a
          -- field for the old password should be presented.
          -- Otherwise, just two fields for the new password are
@@ -385,17 +401,47 @@ 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
+            Nothing   -> notFound
             Just eid' -> getVerifyR eid' verkey False >>= sendResponse
     dispatch "GET" ["verify", eid, verkey, hasSetPass] =
         case fromPathPiece eid of
@@ -420,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>
@@ -442,13 +488,13 @@ defaultEmailLoginHandler toParent = do
         let userRes = UserLoginForm Control.Applicative.<$> emailRes
                                     Control.Applicative.<*> passwordRes
         let widget = do
-            [whamlet|
-                #{extra}
-                <div>
-                    ^{fvInput emailView}
-                <div>
-                    ^{fvInput passwordView}
-            |]
+              [whamlet|
+                  #{extra}
+                  <div>
+                      ^{fvInput emailView}
+                  <div>
+                      ^{fvInput passwordView}
+              |]
 
         return (userRes, widget)
     emailSettings emailMsg = do
@@ -502,11 +548,11 @@ defaultRegisterHandler = do
 
             let userRes = UserForm <$> emailRes
             let widget = do
-                [whamlet|
-                    #{extra}
-                    ^{fvLabel emailView}
-                    ^{fvInput emailView}
-                |]
+                  [whamlet|
+                      #{extra}
+                      ^{fvLabel emailView}
+                      ^{fvInput emailView}
+                  |]
 
             return (userRes, widget)
 
@@ -516,12 +562,12 @@ parseRegister = withObject "email" (\obj -> do
                                       pass <- obj .:? "password"
                                       return (email, pass))
 
-registerHelper :: YesodAuthEmail master
-               => Bool -- ^ allow usernames?
-               -> Bool -- ^ forgot password?
-               -> Route Auth
-               -> AuthHandler master TypedContent
-registerHelper allowUsername forgotPassword dest = do
+defaultRegisterHelper :: YesodAuthEmail master
+                      => Bool -- ^ Allow lookup via username in addition to email
+                      -> Bool -- ^ Set to `True` for forgot password flow, `False` for new account registration
+                      -> Route Auth
+                      -> AuthHandler master TypedContent
+defaultRegisterHelper allowUsername forgotPassword dest = do
     y <- getYesod
     checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
     result <- runInputPostResult $ (,)
@@ -533,7 +579,7 @@ registerHelper allowUsername forgotPassword dest = do
                  _ -> do
                      (creds :: Result Value) <- parseCheckJsonBody
                      return $ case creds of
-                                  Error _ -> Nothing
+                                  Error _     -> Nothing
                                   Success val -> parseMaybe parseRegister val
 
     let eidentifier = case creds of
@@ -546,10 +592,10 @@ registerHelper allowUsername forgotPassword dest = do
 
     let mpass = case (forgotPassword, creds) of
                     (False, Just (_, mp)) -> mp
-                    _ -> Nothing
+                    _                     -> Nothing
 
     case eidentifier of
-      Left route -> loginErrorMessageI dest route
+      Left failMsg -> loginErrorMessageI dest failMsg
       Right identifier -> do
             mecreds <- getEmailCreds identifier
             registerCreds <-
@@ -571,22 +617,25 @@ registerHelper allowUsername forgotPassword dest = do
                             return $ Just (lid, False, key, identifier)
             case registerCreds of
                 Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
-                Just creds'@(_, False, _, _) -> sendConfirmationEmail creds'
-                Just creds'@(_, True, _, _) -> do
-                  if forgotPassword then sendConfirmationEmail creds'
+                Just creds@(_, False, _, _) -> sendConfirmationEmail creds
+                Just creds@(_, True, _, _) -> do
+                  if forgotPassword
+                    then sendConfirmationEmail creds
                     else case emailPreviouslyRegisteredResponse identifier of
                       Just response -> response
-                      Nothing -> sendConfirmationEmail creds'
+                      Nothing       -> sendConfirmationEmail creds
               where sendConfirmationEmail (lid, _, verKey, email) = do
                       render <- getUrlRender
                       tp <- getRouteToParent
                       let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey (isJust mpass)
-                      sendVerifyEmail email verKey verUrl
+                      if forgotPassword
+                         then sendForgotPasswordEmail email verKey verUrl
+                         else sendVerifyEmail email verKey verUrl
                       confirmationEmailSentResponse identifier
 
 
 postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
-postRegisterR = registerHelper False False registerR
+postRegisterR = registerHelper registerR
 
 getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html
 getForgotPasswordR = forgotPasswordHandler
@@ -613,11 +662,11 @@ defaultForgotPasswordHandler = do
 
         let forgotPasswordRes = ForgotPasswordForm <$> emailRes
         let widget = do
-            [whamlet|
-                #{extra}
-                ^{fvLabel emailView}
-                ^{fvInput emailView}
-            |]
+              [whamlet|
+                  #{extra}
+                  ^{fvLabel emailView}
+                  ^{fvInput emailView}
+              |]
         return (forgotPasswordRes, widget)
 
     emailSettings =
@@ -630,7 +679,7 @@ defaultForgotPasswordHandler = do
         }
 
 postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
-postForgotPasswordR = registerHelper True True forgotPasswordR
+postForgotPasswordR = passwordResetHelper forgotPasswordR
 
 getVerifyR :: YesodAuthEmail site
            => AuthEmailId site
@@ -649,7 +698,9 @@ getVerifyR lid key hasSetPass = 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
@@ -691,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
@@ -731,8 +782,8 @@ getPasswordR = do
     maid <- maybeAuthId
     case maid of
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-        Just _ -> do
-            needOld <- maybe (return True) needOldPassword maid
+        Just aid -> do
+            needOld <- needOldPassword aid
             setPasswordHandler needOld
 
 -- | Default implementation of 'setPasswordHandler'.
@@ -760,29 +811,29 @@ defaultSetPasswordHandler needOld = do
 
         let passwordFormRes = PasswordForm <$> currentPasswordRes <*> newPasswordRes <*> confirmPasswordRes
         let widget = do
-            [whamlet|
-                #{extra}
-                <table>
-                    $if needOld
-                        <tr>
-                            <th>
-                                ^{fvLabel currentPasswordView}
-                            <td>
-                                ^{fvInput currentPasswordView}
-                    <tr>
-                        <th>
-                            ^{fvLabel newPasswordView}
-                        <td>
-                            ^{fvInput newPasswordView}
-                    <tr>
-                        <th>
-                            ^{fvLabel confirmPasswordView}
-                        <td>
-                            ^{fvInput confirmPasswordView}
-                    <tr>
-                        <td colspan="2">
-                            <input type=submit value=_{Msg.SetPassTitle}>
-            |]
+              [whamlet|
+                  #{extra}
+                  <table>
+                      $if needOld
+                          <tr>
+                              <th>
+                                  ^{fvLabel currentPasswordView}
+                              <td>
+                                  ^{fvInput currentPasswordView}
+                      <tr>
+                          <th>
+                              ^{fvLabel newPasswordView}
+                          <td>
+                              ^{fvInput newPasswordView}
+                      <tr>
+                          <th>
+                              ^{fvLabel confirmPasswordView}
+                          <td>
+                              ^{fvInput confirmPasswordView}
+                      <tr>
+                          <td colspan="2">
+                              <input type=submit value=_{Msg.SetPassTitle}>
+              |]
 
         return (passwordFormRes, widget)
     currentPasswordSettings =
@@ -822,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
@@ -834,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
@@ -853,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"
@@ -864,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) ->
@@ -884,7 +935,7 @@ postPasswordR = do
 
                      mr <- getMessageRender
                      selectRep $ do
-                         provideRep $ 
+                         provideRep $
                             fmap asHtml $ redirect $ afterPasswordRoute y
                          provideJsonMessage (mr msgOk)
 
@@ -928,9 +979,9 @@ loginLinkKey = "_AUTH_EMAIL_LOGIN_LINK"
 --
 -- @since 1.2.1
 --setLoginLinkKey :: (MonadHandler m) => AuthId site -> m ()
-setLoginLinkKey :: (HasHandlerData env, YesodAuthEmail (HandlerSite env))
-                => AuthId (HandlerSite env)
-                -> RIO env ()
+setLoginLinkKey :: (MonadHandler m, YesodAuthEmail (HandlerSite m))
+                => AuthId (HandlerSite m)
+                -> m ()
 setLoginLinkKey aid = do
     now <- liftIO getCurrentTime
     setSession loginLinkKey $ TS.pack $ show (toPathPiece aid, now)

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -0,0 +1,616 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE TypeFamilies      #-}
+-- | Use an email address as an identifier via Google's login system.
+--
+-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends
+-- on Google's now deprecated OpenID system. For more information, see
+-- <https://developers.google.com/+/api/auth-migration>.
+--
+-- By using this plugin, you are trusting Google to validate an email address,
+-- and requiring users to have a Google account. On the plus side, you get to
+-- use email addresses as the identifier, many users have existing Google
+-- accounts, the login system has been long tested (as opposed to BrowserID),
+-- and it requires no credential managing or setup (as opposed to Email).
+--
+-- In order to use this plugin:
+--
+-- * Create an application on the Google Developer Console <https://console.developers.google.com/>
+--
+-- * Create OAuth credentials. The redirect URI will be <http://yourdomain/auth/page/googleemail2/complete>. (If you have your authentication subsite at a different root than \/auth\/, please adjust accordingly.)
+--
+-- * Enable the Google+ API.
+--
+-- @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
+    , forwardUrl
+    -- * User authentication token
+    , Token(..)
+    , getUserAccessToken
+    -- * Person
+    , getPerson
+    , Person(..)
+    , Name(..)
+    , Gender(..)
+    , PersonImage(..)
+    , resizePersonImage
+    , RelationshipStatus(..)
+    , PersonURI(..)
+    , PersonURIType(..)
+    , Organization(..)
+    , OrganizationType(..)
+    , Place(..)
+    , Email(..)
+    , EmailType(..)
+    -- * Other functions
+    , pid
+    ) where
+
+import           Yesod.Auth                  (Auth, AuthHandler,
+                                              AuthPlugin (AuthPlugin),
+                                              AuthRoute, Creds (Creds),
+                                              Route (PluginR), YesodAuth,
+                                              logoutDest, runHttpRequest,
+                                              setCredsRedirect)
+import qualified Yesod.Auth.Message          as Msg
+import           Yesod.Core                  (HandlerSite, MonadHandler,
+                                              TypedContent, addMessage,
+                                              getRouteToParent, getUrlRender,
+                                              getYesod, invalidArgs, liftIO,
+                                              liftSubHandler, lookupGetParam,
+                                              lookupSession, notFound, redirect,
+                                              setSession, toHtml, whamlet, (.:))
+
+
+import           Blaze.ByteString.Builder    (fromByteString, toByteString)
+import           Control.Applicative         ((<$>), (<*>))
+import           Control.Arrow               (second)
+import           Control.Monad               (unless, when)
+import           Control.Monad.IO.Class      (MonadIO)
+import qualified Crypto.Nonce                as Nonce
+import           Data.Aeson                  ((.:?))
+import qualified Data.Aeson                  as A
+#if MIN_VERSION_aeson(1,0,0)
+import qualified Data.Aeson.Text             as A
+#else
+import qualified Data.Aeson.Encode           as A
+#endif
+import           Data.Aeson.Parser           (json')
+import           Data.Aeson.Types            (FromJSON (parseJSON), parseEither,
+                                              parseMaybe, withObject, withText)
+import           Data.Conduit
+import           Data.Conduit.Attoparsec     (sinkParser)
+import           Data.Maybe                  (fromMaybe)
+import           Data.Monoid                 (mappend)
+import           Data.Text                   (Text)
+import qualified Data.Text                   as T
+import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)
+import qualified Data.Text.Lazy              as TL
+import qualified Data.Text.Lazy.Builder      as TL
+import           Network.HTTP.Client         (Manager, requestHeaders,
+                                              responseBody, urlEncodedBody)
+import qualified Network.HTTP.Client         as HTTP
+import           Network.HTTP.Client.Conduit (Request, bodyReaderSource)
+import           Network.HTTP.Conduit        (http)
+import           Network.HTTP.Types          (renderQueryText)
+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
+-- authentication. The 'credsPlugin' will contain this value when this
+-- plugin is used for authentication.
+-- @since 1.4.17
+pid :: Text
+pid = "googleemail2"
+
+forwardUrl :: AuthRoute
+forwardUrl = PluginR pid ["forward"]
+
+csrfKey :: Text
+csrfKey = "_GOOGLE_CSRF_TOKEN"
+
+getCsrfToken :: MonadHandler m => m (Maybe Text)
+getCsrfToken = lookupSession csrfKey
+
+accessTokenKey :: Text
+accessTokenKey = "_GOOGLE_ACCESS_TOKEN"
+
+-- | Get user's access token from the session. Returns Nothing if it's not found
+--   (probably because the user is not logged in via 'Yesod.Auth.GoogleEmail2'
+--   or you are not using 'authGoogleEmailSaveToken')
+getUserAccessToken :: MonadHandler m => m (Maybe Token)
+getUserAccessToken = fmap (\t -> Token t "Bearer") <$> lookupSession accessTokenKey
+
+getCreateCsrfToken :: MonadHandler m => m Text
+getCreateCsrfToken = do
+    mtoken <- getCsrfToken
+    case mtoken of
+        Just token -> return token
+        Nothing -> do
+            token <- Nonce.nonce128urlT defaultNonceGen
+            setSession csrfKey token
+            return token
+
+authGoogleEmail :: YesodAuth m
+                => Text -- ^ client ID
+                -> Text -- ^ client secret
+                -> AuthPlugin m
+authGoogleEmail = authPlugin False
+
+-- | An alternative version which stores user access token in the session
+--   variable. Use it if you want to request user's profile from your app.
+--
+-- @since 1.4.3
+authGoogleEmailSaveToken :: YesodAuth m
+                         => Text -- ^ client ID
+                         -> Text -- ^ client secret
+                         -> AuthPlugin m
+authGoogleEmailSaveToken = authPlugin True
+
+authPlugin :: YesodAuth m
+           => Bool -- ^ if the token should be stored
+           -> Text -- ^ client ID
+           -> Text -- ^ client secret
+           -> AuthPlugin m
+authPlugin storeToken clientID clientSecret =
+    AuthPlugin pid dispatch login
+  where
+    complete = PluginR pid ["complete"]
+
+    getDest :: MonadHandler m
+            => (Route Auth -> Route (HandlerSite m))
+            -> m Text
+    getDest tm = do
+        csrf <- getCreateCsrfToken
+        render <- getUrlRender
+        let qs = map (second Just)
+                [ ("scope", "email profile")
+                , ("state", csrf)
+                , ("redirect_uri", render $ tm complete)
+                , ("response_type", "code")
+                , ("client_id", clientID)
+                , ("access_type", "offline")
+                ]
+        return $ decodeUtf8
+               $ toByteString
+               $ fromByteString "https://accounts.google.com/o/oauth2/auth"
+                    `Data.Monoid.mappend` renderQueryText True qs
+
+    login tm = do
+        [whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
+
+    dispatch :: YesodAuth site
+             => Text
+             -> [Text]
+             -> AuthHandler site TypedContent
+    dispatch "GET" ["forward"] = do
+        tm <- getRouteToParent
+        getDest tm >>= redirect
+
+    dispatch "GET" ["complete"] = do
+        mstate <- lookupGetParam "state"
+        case mstate of
+            Nothing -> invalidArgs ["CSRF state from Google is missing"]
+            Just state -> do
+                mtoken <- getCsrfToken
+                unless (Just state == mtoken) $ invalidArgs ["Invalid CSRF token from Google"]
+        mcode <- lookupGetParam "code"
+        code <-
+            case mcode of
+                Nothing -> do
+                    merr <- lookupGetParam "error"
+                    case merr of
+                        Nothing -> invalidArgs ["Missing code paramter"]
+                        Just err -> do
+                            master <- getYesod
+                            let msg =
+                                    case err of
+                                        "access_denied" -> "Access denied"
+                                        _ -> "Unknown error occurred: " `T.append` err
+                            addMessage "error" $ toHtml msg
+                            redirect $ logoutDest master
+                Just c -> return c
+
+        render <- getUrlRender
+        tm <- getRouteToParent
+
+        req' <- liftIO $
+            HTTP.parseUrlThrow
+            "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
+        let req =
+                urlEncodedBody
+                    [ ("code", encodeUtf8 code)
+                    , ("client_id", encodeUtf8 clientID)
+                    , ("client_secret", encodeUtf8 clientSecret)
+                    , ("redirect_uri", encodeUtf8 $ render $ tm complete)
+                    , ("grant_type", "authorization_code")
+                    ]
+                    req'
+                        { requestHeaders = []
+                        }
+        value <- makeHttpRequest req
+        token@(Token accessToken' tokenType') <-
+            case parseEither parseJSON value of
+                Left e  -> error e
+                Right t -> return t
+
+        unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType'
+
+        -- User's access token is saved for further access to API
+        when storeToken $ setSession accessTokenKey accessToken'
+
+        personValReq <- personValueRequest token
+        personValue <- makeHttpRequest personValReq
+
+        person <- case parseEither parseJSON personValue of
+                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"
+                x   -> error $ "Too many account emails: " ++ show x
+        setCredsRedirect $ Creds pid email $ allPersonInfo personValue
+
+    dispatch _ _ = notFound
+
+makeHttpRequest :: Request -> AuthHandler site A.Value
+makeHttpRequest req =
+    liftSubHandler $ runHttpRequest req $ \res ->
+    runConduit $ bodyReaderSource (responseBody res) .| sinkParser json'
+
+-- | Allows to fetch information about a user from Google's API.
+--   In case of parsing error returns 'Nothing'.
+--   Will throw 'HttpException' in case of network problems or error response code.
+--
+-- @since 1.4.3
+getPerson :: MonadHandler m => Manager -> Token -> m (Maybe Person)
+getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do
+    req <- personValueRequest token
+    res <- http req manager
+    runConduit $ responseBody res .| sinkParser json'
+  )
+
+personValueRequest :: MonadIO m => Token -> m Request
+personValueRequest token = do
+    req2' <- liftIO
+           $ HTTP.parseUrlThrow "https://www.googleapis.com/plus/v1/people/me"
+    return req2'
+            { requestHeaders =
+                [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)
+                ]
+            }
+
+--------------------------------------------------------------------------------
+-- | An authentication token which was acquired from OAuth callback.
+--   The token gets saved into the session storage only if you use
+--   'authGoogleEmailSaveToken'.
+--   You can acquire saved token with 'getUserAccessToken'.
+--
+-- @since 1.4.3
+data Token = Token { accessToken :: Text
+                   , tokenType   :: Text
+                   } deriving (Show, Eq)
+
+instance FromJSON Token where
+    parseJSON = withObject "Tokens" $ \o -> Token
+        Control.Applicative.<$> o .: "access_token"
+        Control.Applicative.<*> o .: "token_type"
+
+--------------------------------------------------------------------------------
+-- | Gender of the person
+--
+-- @since 1.4.3
+data Gender = Male | Female | OtherGender deriving (Show, Eq)
+
+instance FromJSON Gender where
+    parseJSON = withText "Gender" $ \t -> return $ case t of
+                                                "male"   -> Male
+                                                "female" -> Female
+                                                _        -> OtherGender
+
+--------------------------------------------------------------------------------
+-- | URIs specified in the person's profile
+--
+-- @since 1.4.3
+data PersonURI =
+    PersonURI { uriLabel :: Maybe Text
+              , uriValue :: Maybe Text
+              , uriType  :: Maybe PersonURIType
+              } deriving (Show, Eq)
+
+instance FromJSON PersonURI where
+    parseJSON = withObject "PersonURI" $ \o -> PersonURI <$> o .:? "label"
+                                                         <*> o .:? "value"
+                                                         <*> o .:? "type"
+
+--------------------------------------------------------------------------------
+-- | The type of URI
+--
+-- @since 1.4.3
+data PersonURIType = OtherProfile       -- ^ URI for another profile
+                   | Contributor        -- ^ URI to a site for which this person is a contributor
+                   | Website            -- ^ URI for this Google+ Page's primary website
+                   | OtherURI           -- ^ Other URL
+                   | PersonURIType Text -- ^ Something else
+                   deriving (Show, Eq)
+
+instance FromJSON PersonURIType where
+    parseJSON = withText "PersonURIType" $ \t -> return $ case t of
+            "otherProfile" -> OtherProfile
+            "contributor"  -> Contributor
+            "website"      -> Website
+            "other"        -> OtherURI
+            _              -> PersonURIType t
+
+--------------------------------------------------------------------------------
+-- | Current or past organizations with which this person is associated
+--
+-- @since 1.4.3
+data Organization =
+    Organization { orgName      :: Maybe Text
+                   -- ^ The person's job title or role within the organization
+                 , orgTitle     :: Maybe Text
+                 , orgType      :: Maybe OrganizationType
+                   -- ^ The date that the person joined this organization.
+                 , orgStartDate :: Maybe Text
+                   -- ^ The date that the person left this organization.
+                 , orgEndDate   :: Maybe Text
+                   -- ^ If @True@, indicates this organization is the person's
+                   -- ^ primary one, which is typically interpreted as the current one.
+                 , orgPrimary   :: Maybe Bool
+                 } deriving (Show, Eq)
+
+instance FromJSON Organization where
+    parseJSON = withObject "Organization" $ \o ->
+        Organization <$> o .:? "name"
+                     <*> o .:? "title"
+                     <*> o .:? "type"
+                     <*> o .:? "startDate"
+                     <*> o .:? "endDate"
+                     <*> o .:? "primary"
+
+--------------------------------------------------------------------------------
+-- | The type of an organization
+--
+-- @since 1.4.3
+data OrganizationType = Work
+                      | School
+                      | OrganizationType Text -- ^ Something else
+                      deriving (Show, Eq)
+instance FromJSON OrganizationType where
+    parseJSON = withText "OrganizationType" $ \t -> return $ case t of
+                                                "work"   -> Work
+                                                "school" -> School
+                                                _        -> OrganizationType t
+
+--------------------------------------------------------------------------------
+-- | A place where the person has lived or is living at the moment.
+--
+-- @since 1.4.3
+data Place =
+    Place { -- | A place where this person has lived. For example: "Seattle, WA", "Near Toronto".
+            placeValue   :: Maybe Text
+            -- | If @True@, this place of residence is this person's primary residence.
+          , placePrimary :: Maybe Bool
+          } deriving (Show, Eq)
+
+instance FromJSON Place where
+    parseJSON = withObject "Place" $ \o -> Place <$> (o .:? "value") <*> (o .:? "primary")
+
+--------------------------------------------------------------------------------
+-- | Individual components of a name
+--
+-- @since 1.4.3
+data Name =
+    Name { -- | The full name of this person, including middle names, suffixes, etc
+           nameFormatted       :: Maybe Text
+           -- | The family name (last name) of this person
+         , nameFamily          :: Maybe Text
+           -- | The given name (first name) of this person
+         , nameGiven           :: Maybe Text
+           -- | The middle name of this person.
+         , nameMiddle          :: Maybe Text
+           -- | The honorific prefixes (such as "Dr." or "Mrs.") for this person
+         , nameHonorificPrefix :: Maybe Text
+           -- | The honorific suffixes (such as "Jr.") for this person
+         , nameHonorificSuffix :: Maybe Text
+         } deriving (Show, Eq)
+
+instance FromJSON Name where
+    parseJSON = withObject "Name" $ \o -> Name <$> o .:? "formatted"
+                                               <*> o .:? "familyName"
+                                               <*> o .:? "givenName"
+                                               <*> o .:? "middleName"
+                                               <*> o .:? "honorificPrefix"
+                                               <*> o .:? "honorificSuffix"
+
+--------------------------------------------------------------------------------
+-- | The person's relationship status.
+--
+-- @since 1.4.3
+data RelationshipStatus = Single              -- ^ Person is single
+                        | InRelationship      -- ^ Person is in a relationship
+                        | Engaged             -- ^ Person is engaged
+                        | Married             -- ^ Person is married
+                        | Complicated         -- ^ The relationship is complicated
+                        | OpenRelationship    -- ^ Person is in an open relationship
+                        | Widowed             -- ^ Person is widowed
+                        | DomesticPartnership -- ^ Person is in a domestic partnership
+                        | CivilUnion          -- ^ Person is in a civil union
+                        | RelationshipStatus Text -- ^ Something else
+                        deriving (Show, Eq)
+
+instance FromJSON RelationshipStatus where
+    parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of
+                  "single"                  -> Single
+                  "in_a_relationship"       -> InRelationship
+                  "engaged"                 -> Engaged
+                  "married"                 -> Married
+                  "its_complicated"         -> Complicated
+                  "open_relationship"       -> OpenRelationship
+                  "widowed"                 -> Widowed
+                  "in_domestic_partnership" -> DomesticPartnership
+                  "in_civil_union"          -> CivilUnion
+                  _                         -> RelationshipStatus t
+
+--------------------------------------------------------------------------------
+-- | The URI of the person's profile photo.
+--
+-- @since 1.4.3
+newtype PersonImage = PersonImage { imageUri :: Text } deriving (Show, Eq)
+
+instance FromJSON PersonImage where
+    parseJSON = withObject "PersonImage" $ \o -> PersonImage <$> o .: "url"
+
+-- | @resizePersonImage img 30@ would set query part to @?sz=30@ which would resize
+--   the image under the URI. If for some reason you need to modify the query
+--   part, you should do it after resizing.
+--
+-- @since 1.4.3
+resizePersonImage :: PersonImage -> Int -> PersonImage
+resizePersonImage (PersonImage uri) size =
+    PersonImage $ uri `mappend` "?sz=" `mappend` T.pack (show size)
+
+--------------------------------------------------------------------------------
+-- | Information about the user
+--   Full description of the resource https://developers.google.com/+/api/latest/people
+--
+-- @since 1.4.3
+data Person = Person
+    { personId                 :: Text
+      -- | The name of this person, which is suitable for display
+    , personDisplayName        :: Maybe Text
+    , personName               :: Maybe Name
+    , personNickname           :: Maybe Text
+    , personBirthday           :: Maybe Text -- ^ Birthday formatted as YYYY-MM-DD
+    , personGender             :: Maybe Gender
+    , personProfileUri         :: Maybe Text -- ^ The URI of this person's profile
+    , personImage              :: Maybe PersonImage
+    , personAboutMe            :: Maybe Text -- ^ A short biography for this person
+    , personRelationshipStatus :: Maybe RelationshipStatus
+    , personUris               :: [PersonURI]
+    , personOrganizations      :: [Organization]
+    , personPlacesLived        :: [Place]
+    -- | The brief description of this person
+    , personTagline            :: Maybe Text
+    -- | Whether this user has signed up for Google+
+    , personIsPlusUser         :: Maybe Bool
+    -- | The "bragging rights" line of this person
+    , personBraggingRights     :: Maybe Text
+    -- | if a Google+ page, the number of people who have +1'd this page
+    , personPlusOneCount       :: Maybe Int
+    -- | For followers who are visible, the number of people who have added
+    --   this person or page to a circle.
+    , personCircledByCount     :: Maybe Int
+    -- | Whether the person or Google+ Page has been verified. This is used only
+    --   for pages with a higher risk of being impersonated or similar. This
+    --   flag will not be present on most profiles.
+    , personVerified           :: Maybe Bool
+    -- | The user's preferred language for rendering.
+    , personLanguage           :: Maybe Text
+    , personEmails             :: [Email]
+    , personDomain             :: Maybe Text
+    , personOccupation         :: Maybe Text -- ^ The occupation of this person
+    , personSkills             :: Maybe Text -- ^ The person's skills
+    } deriving (Show, Eq)
+
+
+instance FromJSON Person where
+    parseJSON = withObject "Person" $ \o ->
+        Person <$> o .:  "id"
+               <*> o .:  "displayName"
+               <*> o .:? "name"
+               <*> o .:? "nickname"
+               <*> o .:? "birthday"
+               <*> o .:? "gender"
+               <*> (o .:? "url")
+               <*> o .:? "image"
+               <*> o .:? "aboutMe"
+               <*> o .:? "relationshipStatus"
+               <*> ((fromMaybe []) <$> (o .:? "urls"))
+               <*> ((fromMaybe []) <$> (o .:? "organizations"))
+               <*> ((fromMaybe []) <$> (o .:? "placesLived"))
+               <*> o .:? "tagline"
+               <*> o .:? "isPlusUser"
+               <*> o .:? "braggingRights"
+               <*> o .:? "plusOneCount"
+               <*> o .:? "circledByCount"
+               <*> o .:? "verified"
+               <*> o .:? "language"
+               <*> ((fromMaybe []) <$> (o .:? "emails"))
+               <*> o .:? "domain"
+               <*> o .:? "occupation"
+               <*> o .:? "skills"
+
+--------------------------------------------------------------------------------
+-- | Person's email
+--
+-- @since 1.4.3
+data Email = Email
+    { emailValue :: Text
+    , emailType  :: EmailType
+    }
+    deriving (Show, Eq)
+
+instance FromJSON Email where
+    parseJSON = withObject "Email" $ \o -> Email
+        <$> o .: "value"
+        <*> o .: "type"
+
+--------------------------------------------------------------------------------
+-- | Type of email
+--
+-- @since 1.4.3
+data EmailType = EmailAccount   -- ^ Google account email address
+               | EmailHome      -- ^ Home email address
+               | EmailWork      -- ^ Work email adress
+               | EmailOther     -- ^ Other email address
+               | EmailType Text -- ^ Something else
+               deriving (Show, Eq)
+
+instance FromJSON EmailType where
+    parseJSON = withText "EmailType" $ \t -> return $ case t of
+        "account" -> EmailAccount
+        "home"    -> EmailHome
+        "work"    -> EmailWork
+        "other"   -> EmailOther
+        _         -> EmailType t
+
+allPersonInfo :: A.Value -> [(Text, Text)]
+allPersonInfo (A.Object o) = map enc $ mapToList o
+  where
+    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 _ = []
+
+
+-- See https://github.com/yesodweb/yesod/issues/1245 for discussion on this
+-- use of unsafePerformIO.
+defaultNonceGen :: Nonce.Generator
+defaultNonceGen = unsafePerformIO (Nonce.new)
+{-# NOINLINE defaultNonceGen #-}

yesod-auth/Yesod/Auth/Hardcoded.hs

@@ -131,10 +131,9 @@ module Yesod.Auth.Hardcoded
   , loginR )
   where
 
-import           Yesod.Auth          (AuthPlugin (..), AuthRoute,
+import           Yesod.Auth          (AuthHandler, AuthPlugin (..), AuthRoute,
                                       Creds (..), Route (..), YesodAuth,
-                                      loginErrorMessageI, setCredsRedirect,
-                                      AuthHandler)
+                                      loginErrorMessageI, setCredsRedirect)
 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 UserName = "Benutzername" -- FIXME by Google Translate "user name"
+germanMessage Email = "E-Mail"
+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 InvalidEmailAddress = "Unzulässiger Email-Anbieter"
+germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben"
+germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter"
 germanMessage PasswordResetTitle = "Passwort zurücksetzen"
-germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"
-germanMessage SendPasswordResetEmail = "Email 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 ProvideIdentifier = "E-Mail-Adresse oder Nutzername"
+germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen"
+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
-germanMessage Logout = "Ausloggen" -- FIXME by Google Translate
-germanMessage LogoutTitle = "Ausloggen" -- FIXME by Google Translate
-germanMessage AuthError = "Autorisierungsfehler" -- FIXME by Google Translate
+germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO
+germanMessage Logout = "Abmelden"
+germanMessage LogoutTitle = "Abmelden"
+germanMessage AuthError = "Fehler beim Anmelden"
 
 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/OpenId.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 module Yesod.Auth.OpenId
     ( authOpenId
     , forwardUrl
@@ -30,7 +29,7 @@ forwardUrl = PluginR "openid" ["forward"]
 
 data IdentifierType = Claimed | OPLocal
 
-authOpenId :: forall master. YesodAuth master
+authOpenId :: YesodAuth master
            => IdentifierType
            -> [(Text, Text)] -- ^ extension fields
            -> AuthPlugin master
@@ -42,15 +41,16 @@ authOpenId idType extensionFields =
     name :: Text
     name = "openid_identifier"
 
-    login
-      :: (AuthRoute -> Route master)
-      -> WidgetFor master ()
     login tm = do
         ident <- newIdent
-        toWidget [cassius|##{ident}
+        -- FIXME this is a hack to get GHC 7.6's type checker to allow the
+        -- code, but it shouldn't be necessary
+        let y :: a -> [(Text, Text)] -> Text
+            y = undefined
+        toWidget (\x -> [cassius|##{ident}
     background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
     padding-left: 18px;
-|]
+|] $ x `asTypeOf` y)
         [whamlet|
 $newline never
 <form method="get" action="@{tm forwardUrl}">
@@ -62,10 +62,7 @@ $newline never
     <input type="submit" value="_{Msg.LoginOpenID}">
 |]
 
-    dispatch
-      :: Text
-      -> [Text]
-      -> SubHandlerFor Auth master TypedContent
+    dispatch :: Text -> [Text] -> AuthHandler master TypedContent
     dispatch "GET" ["forward"] = do
         roid <- runInputGet $ iopt textField name
         case roid of
@@ -89,11 +86,7 @@ $newline never
         completeHelper idType posts
     dispatch _ _ = notFound
 
-completeHelper
-  :: (HasHandlerData env, SubHandlerSite env ~ Auth, YesodAuth (HandlerSite env))
-  => IdentifierType
-  -> [(Text, Text)]
-  -> RIO env TypedContent
+completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
 completeHelper idType gets' = do
     manager <- authHttpManager
     eres <- tryAny $ OpenId.authenticateClaimed gets' manager

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

@@ -3,7 +3,6 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 module Yesod.Auth.Rpxnow
     ( authRpxnow
     ) where
@@ -19,7 +18,7 @@ import Data.Text.Encoding.Error (lenientDecode)
 import Control.Arrow ((***))
 import Network.HTTP.Types (renderQuery)
 
-authRpxnow :: forall master. YesodAuth master
+authRpxnow :: YesodAuth master
            => String -- ^ app name
            -> String -- ^ key
            -> AuthPlugin master

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,6 @@
+cabal-version:   >=1.10
 name:            yesod-auth
-version:         1.6.6
+version:         1.6.11.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -7,7 +8,6 @@ maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        Authentication for Yesod.
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-auth>
@@ -20,8 +20,10 @@ flag network-uri
   default: True
 
 library
-    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
                    , base16-bytestring
                    , base64-bytestring
@@ -43,9 +45,8 @@ library
                    , http-types
                    , memory
                    , nonce                   >= 1.0.2     && < 1.1
-                   , persistent              >= 2.8       && < 2.10
+                   , persistent              >= 2.8
                    , random                  >= 1.0.0.2
-                   , rio
                    , safe
                    , shakespeare
                    , template-haskell
@@ -57,18 +58,20 @@ library
                    , unordered-containers
                    , wai                     >= 1.4
                    , yesod-core              >= 1.6       && < 1.7
-                   , yesod-form              >= 1.6       && < 1.7
+                   , yesod-form              >= 1.6       && < 1.8
                    , yesod-persistent        >= 1.6
 
     if flag(network-uri)
       build-depends: network-uri >= 2.6
 
     exposed-modules: Yesod.Auth
+                     Yesod.Auth.BrowserId
                      Yesod.Auth.Dummy
                      Yesod.Auth.Email
                      Yesod.Auth.OpenId
                      Yesod.Auth.Rpxnow
                      Yesod.Auth.Message
+                     Yesod.Auth.GoogleEmail2
                      Yesod.Auth.Hardcoded
                      Yesod.Auth.Util.PasswordStore
     other-modules:   Yesod.Auth.Routes

yesod-bin/AddHandler.hs

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

yesod-bin/ChangeLog.md

@@ -1,3 +1,33 @@
+# 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)

yesod-bin/Devel.hs

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

yesod-bin/Keter.hs

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

yesod-bin/README.md

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

yesod-bin/main.hs

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

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.6.0.3
+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,12 +19,13 @@ 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
                      , Cabal              >= 1.18
                      , bytestring         >= 0.9.1.4
                      , conduit            >= 1.3
@@ -34,7 +35,7 @@ executable             yesod
                      , directory          >= 1.2.1
                      , file-embed
                      , filepath           >= 1.1
-                     , fsnotify           >= 0.0          && < 0.4
+                     , fsnotify
                      , http-client        >= 0.4.7
                      , http-client-tls
                      , http-reverse-proxy >= 0.4
@@ -60,6 +61,7 @@ executable             yesod
                      , warp-tls           >= 3.0.1
                      , yaml               >= 0.8          && < 0.12
                      , zlib               >= 0.5
+                     , aeson
 
     ghc-options:       -Wall -threaded -rtsopts
     main-is:           main.hs

yesod-core/ChangeLog.md

@@ -1,8 +1,155 @@
 # ChangeLog for yesod-core
 
-## 2.0.0.0
+## 1.6.25.1
 
-* Switch over to using `rio`
+* 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
 

yesod-core/src/Yesod/Core.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module Yesod.Core
     ( -- * Type classes
@@ -30,6 +29,10 @@ module Yesod.Core
     , AuthResult (..)
     , unauthorizedI
       -- * Logging
+    , defaultMakeLogger
+    , defaultMessageLoggerSource
+    , defaultShouldLogIO
+    , formatLogMessage
     , LogLevel (..)
     , logDebug
     , logInfo
@@ -64,10 +67,8 @@ module Yesod.Core
     , ScriptLoadPosition (..)
     , BottomOfHeadAsync
     -- * Generalizing type classes
-    , HasHandlerData (..)
-    , HasWidgetData (..)
-    , liftHandler
-    , liftWidget
+    , MonadHandler (..)
+    , MonadWidget (..)
       -- * Approot
     , guessApproot
     , guessApprootOr
@@ -75,6 +76,7 @@ module Yesod.Core
       -- * Misc
     , yesodVersion
     , yesodRender
+    , Yesod.Core.runFakeHandler
       -- * LiteApp
     , module Yesod.Core.Internal.LiteApp
       -- * Low-level
@@ -92,9 +94,12 @@ module Yesod.Core
     , MonadIO (..)
     , MonadUnliftIO (..)
     , MonadResource (..)
-    , RIO
+    , MonadLogger
       -- * Commonly referenced functions/datatypes
     , Application
+      -- * Utilities
+    , showIntegral
+    , readIntegral
       -- * Shakespeare
       -- ** Hamlet
     , hamlet
@@ -115,6 +120,7 @@ module Yesod.Core
 import Yesod.Core.Content
 import Yesod.Core.Dispatch
 import Yesod.Core.Handler
+import Yesod.Core.Class.Handler
 import Yesod.Core.Widget
 import Yesod.Core.Json
 import Yesod.Core.Types
@@ -122,16 +128,18 @@ import Text.Shakespeare.I18N
 import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)
 import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)
 
+import Control.Monad.Logger
 import Control.Monad.Trans.Class (MonadTrans (..))
 import Yesod.Core.Internal.Session
 import Yesod.Core.Internal.Run (yesodRunner, yesodRender)
 import Yesod.Core.Class.Yesod
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Class.Breadcrumbs
+import qualified Yesod.Core.Internal.Run
 import qualified Paths_yesod_core
 import Data.Version (showVersion)
 import Yesod.Routes.Class
-import RIO
+import UnliftIO (MonadIO (..), MonadUnliftIO (..))
 
 import Control.Monad.Trans.Resource (MonadResource (..))
 import Yesod.Core.Internal.LiteApp
@@ -141,11 +149,17 @@ import Text.Lucius
 import Text.Julius
 import Network.Wai (Application)
 
+runFakeHandler :: (Yesod site, MonadIO m) =>
+                  SessionMap
+               -> (site -> Logger)
+               -> site
+               -> HandlerT site IO a
+               -> m (Either ErrorResponse a)
+runFakeHandler = Yesod.Core.Internal.Run.runFakeHandler
+{-# DEPRECATED runFakeHandler "import runFakeHandler from Yesod.Core.Unsafe" #-}
+
 -- | Return an 'Unauthorized' value, with the given i18n message.
-unauthorizedI
-  :: (HasHandlerData env, RenderMessage (HandlerSite env) msg)
-  => msg
-  -> RIO env AuthResult
+unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult
 unauthorizedI msg = do
     mr <- getMessageRender
     return $ Unauthorized $ mr msg
@@ -164,3 +178,12 @@ maybeAuthorized :: Yesod site
 maybeAuthorized r isWrite = do
     x <- isAuthorized r isWrite
     return $ if x == Authorized then Just r else Nothing
+
+showIntegral :: Integral a => a -> String
+showIntegral x = show (fromIntegral x :: Integer)
+
+readIntegral :: Num a => String -> Maybe a
+readIntegral s =
+    case reads s of
+        (i, _):_ -> Just $ fromInteger i
+        [] -> Nothing

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
-        (title, next) <- breadcrumb this
-        go ((this, title) : back) next
+    go back (Just this)
+      | this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this
+      | otherwise = do
+          (title, next) <- breadcrumb this
+          go ((this, title) : back) next

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

@@ -4,10 +4,8 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 module Yesod.Core.Class.Dispatch where
 
-import RIO
 import qualified Network.Wai as W
 import Yesod.Core.Types
 import Yesod.Core.Content (ToTypedContent (..))
@@ -32,8 +30,8 @@ instance YesodSubDispatch WaiSubsiteWithAuth master where
       ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
     where
       route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []
-      WaiSubsiteWithAuth set' = ysreGetSub $ yreSite $ ysreParentEnv
-      handlert = sendWaiApplication set'
+      WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
+      handlert = sendWaiApplication set
 
 subHelper
   :: ToTypedContent content
@@ -41,15 +39,14 @@ subHelper
   -> YesodSubRunnerEnv child master
   -> Maybe (Route child)
   -> W.Application
-subHelper subHandler YesodSubRunnerEnv {..} mroute =
+subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =
     ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)
   where
-    handler = fmap toTypedContent $ do
-      hd <- view subHandlerDataL
+    handler = fmap toTypedContent $ HandlerFor $ \hd ->
       let rhe = handlerEnv hd
           rhe' = rhe
             { rheRoute = mroute
             , rheChild = ysreGetSub $ yreSite ysreParentEnv
             , rheRouteToMaster = ysreToParentRoute
             }
-      runRIO hd { handlerEnv = rhe' } subHandler
+       in f hd { handlerEnv = rhe' }

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

@@ -0,0 +1,126 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Yesod.Core.Class.Handler
+    ( MonadHandler (..)
+    , MonadWidget (..)
+    , liftHandlerT
+    , liftWidgetT
+    ) where
+
+import Yesod.Core.Types
+import Control.Monad.Logger (MonadLogger)
+import Control.Monad.Trans.Resource (MonadResource)
+import Control.Monad.Trans.Class (lift)
+import Data.Conduit.Internal (Pipe, ConduitM)
+
+import Control.Monad.Trans.Identity ( IdentityT)
+#if !MIN_VERSION_transformers(0,6,0)
+import Control.Monad.Trans.List     ( ListT    )
+#endif
+import Control.Monad.Trans.Maybe    ( MaybeT   )
+import Control.Monad.Trans.Except   ( ExceptT  )
+import Control.Monad.Trans.Reader   ( ReaderT  )
+import Control.Monad.Trans.State    ( StateT   )
+import Control.Monad.Trans.Writer   ( WriterT  )
+import Control.Monad.Trans.RWS      ( RWST     )
+import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )
+import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )
+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
+
+-- FIXME should we just use MonadReader instances instead?
+class (MonadResource m, MonadLogger m) => MonadHandler m where
+    type HandlerSite m
+    type SubHandlerSite m
+    liftHandler :: HandlerFor (HandlerSite m) a -> m a
+    liftSubHandler :: SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a
+
+liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a
+liftHandlerT = liftHandler
+{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-}
+
+instance MonadHandler (HandlerFor site) where
+    type HandlerSite (HandlerFor site) = site
+    type SubHandlerSite (HandlerFor site) = site
+    liftHandler = id
+    {-# INLINE liftHandler #-}
+    liftSubHandler (SubHandlerFor f) = HandlerFor f
+    {-# INLINE liftSubHandler #-}
+
+instance MonadHandler (SubHandlerFor sub master) where
+    type HandlerSite (SubHandlerFor sub master) = master
+    type SubHandlerSite (SubHandlerFor sub master) = sub
+    liftHandler (HandlerFor f) = SubHandlerFor $ \hd -> f hd
+      { handlerEnv =
+          let rhe = handlerEnv hd
+           in rhe
+                { rheRoute = fmap (rheRouteToMaster rhe) (rheRoute rhe)
+                , rheRouteToMaster = id
+                , rheChild = rheSite rhe
+                }
+      }
+    {-# INLINE liftHandler #-}
+    liftSubHandler = id
+    {-# INLINE liftSubHandler #-}
+
+instance MonadHandler (WidgetFor site) where
+    type HandlerSite (WidgetFor site) = site
+    type SubHandlerSite (WidgetFor site) = site
+    liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler
+    {-# INLINE liftHandler #-}
+    liftSubHandler (SubHandlerFor f) = WidgetFor $ f . wdHandler
+    {-# INLINE liftSubHandler #-}
+
+#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
+#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
+GO(IdentityT)
+#if !MIN_VERSION_transformers(0,6,0)
+GO(ListT)
+#endif
+GO(MaybeT)
+GO(ExceptT e)
+GO(ReaderT r)
+GO(StateT s)
+GOX(Monoid w, WriterT w)
+GOX(Monoid w, RWST r w s)
+GOX(Monoid w, Strict.RWST r w s)
+GO(Strict.StateT s)
+GOX(Monoid w, Strict.WriterT w)
+GO(Pipe l i o u)
+GO(ConduitM i o)
+#undef GO
+#undef GOX
+
+class MonadHandler m => MonadWidget m where
+    liftWidget :: WidgetFor (HandlerSite m) a -> m a
+instance MonadWidget (WidgetFor site) where
+    liftWidget = id
+    {-# INLINE liftWidget #-}
+
+liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a
+liftWidgetT = liftWidget
+{-# DEPRECATED liftWidgetT "Use liftWidget instead" #-}
+
+#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget
+#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget
+GO(IdentityT)
+#if !MIN_VERSION_transformers(0,6,0)
+GO(ListT)
+#endif
+GO(MaybeT)
+GO(ExceptT e)
+GO(ReaderT r)
+GO(StateT s)
+GOX(Monoid w, WriterT w)
+GOX(Monoid w, RWST r w s)
+GOX(Monoid w, Strict.RWST r w s)
+GO(Strict.StateT s)
+GOX(Monoid w, Strict.WriterT w)
+GO(Pipe l i o u)
+GO(ConduitM i o)
+#undef GO
+#undef GOX

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

@@ -1,11 +1,10 @@
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell   #-}
-module Yesod.Core.Class.Yesod where
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
-import           RIO
+module Yesod.Core.Class.Yesod where
 
 import           Yesod.Core.Content
 import           Yesod.Core.Handler
@@ -15,6 +14,11 @@ import           Yesod.Routes.Class
 import           Data.ByteString.Builder            (Builder)
 import           Data.Text.Encoding                 (encodeUtf8Builder)
 import           Control.Arrow                      ((***), second)
+import           Control.Exception                  (bracket)
+import           Control.Monad                      (forM, when, void)
+import           Control.Monad.IO.Class             (MonadIO (liftIO))
+import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelOther),
+                                                     LogSource, logErrorS)
 import           Control.Monad.Trans.Resource       (InternalState, createInternalState, closeInternalState)
 import qualified Data.ByteString.Char8              as S8
 import qualified Data.ByteString.Lazy               as L
@@ -28,12 +32,15 @@ import qualified Data.Text                          as T
 import qualified Data.Text.Encoding                 as TE
 import qualified Data.Text.Encoding.Error           as TEE
 import           Data.Text.Lazy.Builder             (toLazyText)
-import qualified Data.Text.Lazy.Encoding            as TLE (encodeUtf8)
+import           Data.Text.Lazy.Encoding            (encodeUtf8)
+import           Data.Word                          (Word64)
 import           Language.Haskell.TH.Syntax         (Loc (..))
 import           Network.HTTP.Types                 (encodePath)
 import qualified Network.Wai                        as W
 import           Network.Wai.Parse                  (lbsBackEnd,
                                                      tempFileBackEnd)
+import           Network.Wai.Logger                 (ZonedDate, clockDateCacher)
+import           System.Log.FastLogger
 import           Text.Blaze                         (customAttribute, textTag,
                                                      toValue, (!),
                                                      preEscapedToMarkup)
@@ -47,7 +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.
@@ -64,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'.
@@ -81,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
@@ -209,15 +231,29 @@ class RenderRoute site => Yesod site where
     maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)
     maximumContentLengthIO a b = pure $ maximumContentLength a b
 
-    -- | Get the 'LogFunc' from the foundation type.
+    -- | Creates a @Logger@ to use for log messages.
     --
-    -- If this function returns a @Nothing@ (the default), the Yesod
-    -- codebase itself will create a log function for you with some
-    -- default settings. Overriding this allows you to have more
-    -- control, and also to share your log function with code outside
-    -- of your handlers.
-    getLogFunc :: site -> Maybe LogFunc
-    getLogFunc _ = Nothing
+    -- Note that a common technique (endorsed by the scaffolding) is to create
+    -- a @Logger@ value and place it in your foundation datatype, and have this
+    -- method return that already created value. That way, you can use that
+    -- same @Logger@ for printing messages during app initialization.
+    --
+    -- Default: the 'defaultMakeLogger' function.
+    makeLogger :: site -> IO Logger
+    makeLogger _ = defaultMakeLogger
+
+    -- | Send a message to the @Logger@ provided by @getLogger@.
+    --
+    -- Default: the 'defaultMessageLoggerSource' function, using
+    -- 'shouldLogIO' to check whether we should log.
+    messageLoggerSource :: site
+                        -> Logger
+                        -> Loc -- ^ position in source code
+                        -> LogSource
+                        -> LogLevel
+                        -> LogStr -- ^ message
+                        -> IO ()
+    messageLoggerSource site = defaultMessageLoggerSource $ shouldLogIO site
 
     -- | Where to Load sripts from. We recommend the default value,
     -- 'BottomOfBody'.
@@ -229,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
@@ -248,6 +294,14 @@ class RenderRoute site => Yesod site where
         | size <= 50000 = FileUploadMemory lbsBackEnd
     fileUpload _ _ = FileUploadDisk tempFileBackEnd
 
+    -- | Should we log the given log source/level combination.
+    --
+    -- Default: the 'defaultShouldLogIO' function.
+    --
+    -- Since 1.2.4
+    shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool
+    shouldLogIO _ = defaultShouldLogIO
+
     -- | A Yesod middleware, which will wrap every handler function. This
     -- allows you to run code before and after a normal handler.
     --
@@ -284,6 +338,44 @@ class RenderRoute site => Yesod site where
                 ^{body}
             |]
 
+-- | Default implementation of 'makeLogger'. Sends to stdout and
+-- automatically flushes on each write.
+--
+-- Since 1.4.10
+defaultMakeLogger :: IO Logger
+defaultMakeLogger = do
+    loggerSet' <- newStdoutLoggerSet defaultBufSize
+    (getter, _) <- clockDateCacher
+    return $! Logger loggerSet' getter
+
+-- | Default implementation of 'messageLoggerSource'. Checks if the
+-- message should be logged using the provided function, and if so,
+-- formats using 'formatLogMessage'. You can use 'defaultShouldLogIO'
+-- as the provided function.
+--
+-- Since 1.4.10
+defaultMessageLoggerSource ::
+       (LogSource -> LogLevel -> IO Bool) -- ^ Check whether we should
+                                          -- log this
+    -> Logger
+    -> Loc -- ^ position in source code
+    -> LogSource
+    -> LogLevel
+    -> LogStr -- ^ message
+    -> IO ()
+defaultMessageLoggerSource ckLoggable logger loc source level msg = do
+    loggable <- ckLoggable source level
+    when loggable $
+        formatLogMessage (loggerDate logger) loc source level msg >>=
+        loggerPutStr logger
+
+-- | Default implementation of 'shouldLog'. Logs everything at or
+-- above 'LevelInfo'.
+--
+-- Since 1.4.10
+defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool
+defaultShouldLogIO _ level = return $ level >= LevelInfo
+
 -- | Default implementation of 'yesodMiddleware'. Adds the response header
 -- \"Vary: Accept, Accept-Language\", \"X-XSS-Protection: 1; mode=block\", and
 -- performs authorization checks.
@@ -352,10 +444,12 @@ sameSiteSession s = (fmap . fmap) secureSessionCookies
 sslOnlyMiddleware :: Int -- ^ minutes
                   -> HandlerFor site res
                   -> HandlerFor site res
-sslOnlyMiddleware timeout' handler = do
+sslOnlyMiddleware timeout handler = do
     addHeader "Strict-Transport-Security"
-              $ utf8BuilderToText -- FIXME should we store headers as Utf8Builders?
-              $ "max-age=" <> display (timeout' * 60) <> "; includeSubDomains"
+              $ T.pack $ concat [ "max-age="
+                                , show $ timeout * 60
+                                , "; includeSubDomains"
+                                ]
     handler
 
 -- | Check if a given request is authorized via 'isAuthorized' and
@@ -381,7 +475,7 @@ authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
                               void $ redirect url'
                           provideRepType typeJson $
                               void notAuthenticated
-            Unauthorized s' -> permissionDenied $ display s'
+            Unauthorized s' -> permissionDenied s'
 
 -- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
 --
@@ -453,16 +547,21 @@ widgetToPageContent :: Yesod site
                     => WidgetFor site ()
                     -> HandlerFor site (PageContent (Route site))
 widgetToPageContent w = do
-  master <- getYesod
+ jsAttrs <- jsAttributesHandler
+ HandlerFor $ \hd -> do
+  master <- unHandlerFor getYesod hd
   ref <- newIORef mempty
-  hd <- ask
-  runRIO WidgetData { wdRef = ref, wdHandler = hd } w
-  GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref
+  unWidgetFor w WidgetData
+    { wdRef = ref
+    , wdHandler = hd
+    }
+  GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref
   let title = maybe mempty unTitle mTitle
+      description = unDescription <$> mDescription
       scripts = runUniqueList scripts'
       stylesheets = runUniqueList stylesheets'
 
-  do -- just to reduce whitespace diffs
+  flip unHandlerFor hd $ do
     render <- getUrlRenderParams
     let renderLoc x =
             case x of
@@ -472,7 +571,7 @@ widgetToPageContent w = do
     css <- forM (Map.toList style) $ \(mmedia, content) -> do
         let rendered = toLazyText $ content render
         x <- addStaticContent "css" "text/css; charset=utf-8"
-           $ TLE.encodeUtf8 $ rendered
+           $ encodeUtf8 rendered
         return (mmedia,
             case x of
                 Nothing -> Left $ preEscapedToMarkup rendered
@@ -482,7 +581,7 @@ widgetToPageContent w = do
             Nothing -> return Nothing
             Just s -> do
                 x <- addStaticContent "js" "text/javascript; charset=utf-8"
-                   $ TLE.encodeUtf8 $ renderJavascriptUrl render s
+                   $ encodeUtf8 $ renderJavascriptUrl render s
                 return $ renderLoc x
 
     -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing
@@ -494,7 +593,7 @@ widgetToPageContent w = do
                 ^{mkScriptTag s}
             $maybe j <- jscript
                 $maybe s <- jsLoc
-                    <script src="#{s}" *{jsAttributes master}>
+                    <script src="#{s}" *{jsAttrs}>
                 $nothing
                     <script>^{jelper j}
         |]
@@ -528,7 +627,7 @@ widgetToPageContent w = do
             ^{regularScriptLoad}
         |]
 
-    return $ PageContent title headAll $
+    return $ PageContent title description headAll $
         case jsLoader master of
             BottomOfBody -> bodyScript
             _ -> body
@@ -557,7 +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)
+    provideRep $ return ("Not Found" :: Text)
 
 -- For API requests.
 -- For a user with a browser,
@@ -581,7 +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)
+    provideRep $ return ("Not logged in" :: Text)
 
 defaultErrorHandler (PermissionDenied msg) = selectRep $ do
     provideRep $ defaultLayout $ defaultMessageWidget
@@ -600,10 +699,10 @@ defaultErrorHandler (InvalidArgs ia) = selectRep $ do
                     <li>#{msg}
         |]
     provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]
-    provideRep $ return $ ("Invalid Arguments: " <> T.intercalate " " ia)
+    provideRep $ return ("Invalid Arguments: " <> T.intercalate " " ia)
 
 defaultErrorHandler (InternalError e) = do
-    logErrorS "yesod-core" $ display e
+    $logErrorS "yesod-core" e
     selectRep $ do
         provideRep $ defaultLayout $ defaultMessageWidget
             "Internal Server Error"
@@ -641,6 +740,43 @@ asyncHelper render scripts jscript jsLoc =
                     Nothing -> Nothing
                     Just j -> Just $ jelper j
 
+-- | Default formatting for log messages. When you use
+-- the template haskell logging functions for to log with information
+-- about the source location, that information will be appended to
+-- the end of the log. When you use the non-TH logging functions,
+-- like 'logDebugN', this function does not include source
+-- information. This currently works by checking to see if the
+-- package name is the string \"\<unknown\>\". This is a hack,
+-- but it removes some of the visual clutter from non-TH logs.
+--
+-- Since 1.4.10
+formatLogMessage :: IO ZonedDate
+                 -> Loc
+                 -> LogSource
+                 -> LogLevel
+                 -> LogStr -- ^ message
+                 -> IO LogStr
+formatLogMessage getdate loc src level msg = do
+    now <- getdate
+    return $ mempty
+        `mappend` toLogStr now
+        `mappend` " ["
+        `mappend` (case level of
+            LevelOther t -> toLogStr t
+            _ -> toLogStr $ drop 5 $ show level)
+        `mappend` (if T.null src
+            then mempty
+            else "#" `mappend` toLogStr src)
+        `mappend` "] "
+        `mappend` msg
+        `mappend` sourceSuffix
+        `mappend` "\n"
+    where
+    sourceSuffix = if loc_package loc == "<unknown>" then "" else mempty
+        `mappend` " @("
+        `mappend` toLogStr (fileLocationToString loc)
+        `mappend` ")"
+
 -- | Customize the cookies used by the session backend.  You may
 -- use this function on your definition of 'makeSessionBackend'.
 --

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

@@ -64,6 +64,7 @@ import qualified Data.Conduit.Internal as CI
 
 import qualified Data.Aeson as J
 import Data.Text.Lazy.Builder (toLazyText)
+import Data.Void (Void, absurd)
 import Yesod.Core.Types
 import Text.Lucius (Css, renderCss)
 import Text.Julius (Javascript, unJavascript)
@@ -103,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
@@ -160,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
@@ -272,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
@@ -292,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 NoImplicitPrelude #-}
 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 (..)
@@ -39,6 +49,7 @@ module Yesod.Core.Dispatch
 
 import Prelude hiding (exp)
 import Yesod.Core.Internal.TH
+import Language.Haskell.TH.Syntax (qLocation)
 
 import Web.PathPieces
 
@@ -46,6 +57,7 @@ import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
 
+import Data.Bits ((.|.), finiteBitSize, shiftL)
 import Data.Text (Text)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as BL
@@ -59,7 +71,7 @@ import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
 import Text.Read (readMaybe)
 import System.Environment (getEnvironment)
-import qualified System.Random as Random
+import System.Entropy (getEntropy)
 import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
 import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
 
@@ -68,47 +80,45 @@ import Network.Wai.Middleware.AcceptOverride
 import Network.Wai.Middleware.RequestLogger
 import Network.Wai.Middleware.Gzip
 import Network.Wai.Middleware.MethodOverride
-import System.Log.FastLogger (fromLogStr)
 
 import qualified Network.Wai.Handler.Warp
+import System.Log.FastLogger
+import Control.Monad.Logger
 import Control.Monad (when)
 import qualified Paths_yesod_core
 import Data.Version (showVersion)
-import RIO
-
--- | Get a 'LogFunc' from the site, or create if needed. Returns an
--- @IORef@ with a finalizer to clean up when done.
-makeLogFunc :: Yesod site => site -> IO (LogFunc, IORef ())
-makeLogFunc site =
-  case getLogFunc site of
-    Just logFunc -> do
-      ref <- newIORef ()
-      pure (logFunc, ref)
-    Nothing -> do
-      (logFunc, cleanup) <- logOptionsHandle stderr False >>= newLogFunc
-      ref <- newIORef ()
-      _ <- mkWeakIORef ref cleanup
-      pure (logFunc, ref)
 
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. This function will provide no middlewares; if you want commonly
 -- used middlewares, please use 'toWaiApp'.
 toWaiAppPlain :: YesodDispatch site => site -> IO W.Application
 toWaiAppPlain site = do
-    (logFunc, cleanup) <- makeLogFunc site
+    logger <- makeLogger site
     sb <- makeSessionBackend site
     getMaxExpires <- getGetMaxExpires
     return $ toWaiAppYre YesodRunnerEnv
-            { yreLogFunc = logFunc
+            { yreLogger = logger
             , yreSite = site
             , yreSessionBackend = sb
             , yreGen = defaultGen
             , yreGetMaxExpires = getMaxExpires
-            , yreCleanup = cleanup
             }
 
+-- | 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
@@ -158,28 +168,28 @@ toWaiAppYre yre req =
 -- * Accept header override with the _accept query string parameter
 toWaiApp :: YesodDispatch site => site -> IO W.Application
 toWaiApp site = do
-    (logFunc, cleanup) <- makeLogFunc site
-    toWaiAppLogger logFunc cleanup site
+    logger <- makeLogger site
+    toWaiAppLogger logger site
 
-toWaiAppLogger
-  :: YesodDispatch site
-  => LogFunc
-  -> IORef () -- ^ cleanup
-  -> site
-  -> IO W.Application
-toWaiAppLogger logFunc cleanup site = do
+toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
+toWaiAppLogger logger site = do
     sb <- makeSessionBackend site
     getMaxExpires <- getGetMaxExpires
     let yre = YesodRunnerEnv
-                { yreLogFunc = logFunc
+                { yreLogger = logger
                 , yreSite = site
                 , yreSessionBackend = sb
                 , yreGen = defaultGen
                 , yreGetMaxExpires = getMaxExpires
-                , yreCleanup = cleanup
                 }
-    runRIO logFunc $ logInfoS "yesod-core" "Application launched"
-    middleware <- mkDefaultMiddlewares logFunc
+    messageLoggerSource
+        site
+        logger
+        $(qLocation >>= liftLoc)
+        "yesod-core"
+        LevelInfo
+        (toLogStr ("Application launched" :: S.ByteString))
+    middleware <- mkDefaultMiddlewares logger
     return $ middleware $ toWaiAppYre yre
 
 -- | A convenience method to run an application using the Warp webserver on the
@@ -187,21 +197,35 @@ toWaiAppLogger logFunc cleanup 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.
 --
 -- Since 1.2.0
 warp :: YesodDispatch site => Int -> site -> IO ()
 warp port site = do
-    (logFunc, cleanup) <- makeLogFunc site
-    toWaiAppLogger logFunc cleanup site >>= Network.Wai.Handler.Warp.runSettings (
+    logger <- makeLogger site
+    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings (
         Network.Wai.Handler.Warp.setPort port $
         Network.Wai.Handler.Warp.setServerName serverValue $
         Network.Wai.Handler.Warp.setOnException (\_ e ->
                 when (shouldLog' e) $
-                runRIO logFunc $
-                logErrorS "yesod-core" $
-                "Exception from Warp: " <> displayShow e)
+                messageLoggerSource
+                    site
+                    logger
+                    $(qLocation >>= liftLoc)
+                    "yesod-core"
+                    LevelError
+                    (toLogStr $ "Exception from Warp: " ++ show e))
         Network.Wai.Handler.Warp.defaultSettings)
   where
     shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException
@@ -218,14 +242,10 @@ serverValue = S8.pack $ concat
 -- | A default set of middlewares.
 --
 -- Since 1.2.0
-mkDefaultMiddlewares :: LogFunc -> IO W.Middleware
-mkDefaultMiddlewares logFunc = do
+mkDefaultMiddlewares :: Logger -> IO W.Middleware
+mkDefaultMiddlewares logger = do
     logWare <- mkRequestLogger def
-        { destination = Network.Wai.Middleware.RequestLogger.Callback $
-            runRIO logFunc .
-            logInfoS "yesod-core" .
-            displayBytesUtf8 .
-            fromLogStr
+        { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger
         , outputFormat = Apache FromSocket
         }
     return $ logWare . defaultMiddlewaresNoLogging

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

@@ -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,21 +1,38 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternGuards     #-}
-{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TupleSections     #-}
-{-# LANGUAGE FlexibleContexts  #-}
-module Yesod.Core.Internal.Run where
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE PatternGuards       #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Yesod.Core.Internal.Run
+  ( toErrorHandler
+  , errFromShow
+  , basicRunHandler
+  , handleError
+  , handleContents
+  , evalFallback
+  , runHandler
+  , safeEh
+  , runFakeHandler
+  , yesodRunner
+  , yesodRender
+  , resolveApproot
+  )
+  where
 
-
-import           RIO
+import qualified Control.Exception as EUnsafe
 import Yesod.Core.Internal.Response
 import           Data.ByteString.Builder      (toLazyByteString)
 import qualified Data.ByteString.Lazy         as BL
+import           Control.Monad.IO.Class       (MonadIO, liftIO)
+import           Control.Monad.Logger         (LogLevel (LevelError), LogSource,
+                                               liftLoc)
 import           Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, InternalState)
 import qualified Data.ByteString              as S
 import qualified Data.ByteString.Char8        as S8
+import qualified Data.IORef                   as I
 import qualified Data.Map                     as Map
 import           Data.Maybe                   (isJust, fromMaybe)
 import           Data.Monoid                  (appEndo)
@@ -23,9 +40,11 @@ import           Data.Text                    (Text)
 import qualified Data.Text                    as T
 import           Data.Text.Encoding           (encodeUtf8, decodeUtf8With)
 import           Data.Text.Encoding.Error     (lenientDecode)
+import           Language.Haskell.TH.Syntax   (Loc, qLocation)
 import qualified Network.HTTP.Types           as H
 import           Network.Wai
 import           Network.Wai.Internal
+import           System.Log.FastLogger        (LogStr, toLogStr)
 import           Yesod.Core.Content
 import           Yesod.Core.Class.Yesod
 import           Yesod.Core.Types
@@ -34,6 +53,9 @@ import           Yesod.Core.Internal.Request  (parseWaiRequest,
 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
@@ -62,13 +84,13 @@ basicRunHandler :: ToTypedContent c
 basicRunHandler rhe handler yreq resState = do
     -- Create a mutable ref to hold the state. We use mutable refs so
     -- that the updates will survive runtime exceptions.
-    istate <- newIORef defState
+    istate <- I.newIORef defState
 
     -- Run the handler itself, capturing any runtime exceptions and
     -- converting them into a @HandlerContents@
-    contents' <- catchAny
+    contents' <- rheCatchHandlerExceptions rhe
         (do
-            res <- runRIO (hd istate) handler
+            res <- unHandlerFor handler (hd istate)
             tc <- evaluate (toTypedContent res)
             -- Success! Wrap it up in an @HCContent@
             return (HCContent defaultStatus tc))
@@ -78,7 +100,7 @@ basicRunHandler rhe handler yreq resState = do
                 Nothing -> HCError <$> toErrorHandler e)
 
     -- Get the raw state and return
-    state <- readIORef istate
+    state <- I.readIORef istate
     return (state, contents')
   where
     defState = GHState
@@ -89,7 +111,7 @@ basicRunHandler rhe handler yreq resState = do
         , ghsCacheBy = mempty
         , ghsHeaders = mempty
         }
-    hd istate = HandlerData $ SubHandlerData
+    hd istate = HandlerData
         { handlerRequest = yreq
         , handlerEnv     = rhe
         , handlerState   = istate
@@ -167,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
@@ -187,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)
-    (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
+    (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)
+    (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
     contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
 
     -- Convert the HandlerContents into the final YesodResponse
@@ -198,11 +223,12 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
         headers
         contents3
 
-safeEh :: LogFunc -> ErrorResponse -> YesodApp
-safeEh logFunc er req = do
-    runRIO logFunc $
-      logErrorS "yesod-core" $
-      "Error handler errored out: " <> displayShow er
+safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
+       -> ErrorResponse
+       -> YesodApp
+safeEh log' er req = do
+    liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError
+           $ toLogStr $ "Error handler errored out: " ++ show er
     return $ YRPlain
         H.status500
         []
@@ -210,36 +236,36 @@ safeEh logFunc 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.
-runFakeHandler :: (Yesod site, MonadIO m) =>
+-- @HandlerFor@'s return value.
+runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
                   SessionMap
-               -> LogFunc
+               -> (site -> Logger)
                -> site
                -> HandlerFor site a
                -> m (Either ErrorResponse a)
-runFakeHandler fakeSessionMap logFunc site handler = liftIO $ do
-  ret <- newIORef (Left $ InternalError "runFakeHandler: no result")
+runFakeHandler fakeSessionMap logger site handler = liftIO $ do
+  ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
   maxExpires <- getCurrentMaxExpiresRFC1123
-  let handler' = writeIORef ret . Right =<< handler
+  let handler' = liftIO . I.writeIORef ret . Right =<< handler
   let yapp = runHandler
          RunHandlerEnv
             { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
@@ -248,13 +274,14 @@ runFakeHandler fakeSessionMap logFunc site handler = liftIO $ do
             , rheChild = site
             , rheSite = site
             , rheUpload = fileUpload site
-            , rheLogFunc = logFunc
+            , rheLog = messageLoggerSource site $ logger site
             , rheOnError = errHandler
             , rheMaxExpires = maxExpires
+            , rheCatchHandlerExceptions = catchHandlerExceptions site
             }
         handler'
       errHandler err req = do
-          writeIORef ret (Left err)
+          liftIO $ I.writeIORef ret (Left err)
           return $ YRPlain
                      H.status500
                      []
@@ -290,9 +317,9 @@ runFakeHandler fakeSessionMap logFunc site handler = liftIO $ do
           , reqSession    = fakeSessionMap
           }
   _ <- runResourceT $ yapp fakeRequest
-  readIORef ret
+  I.readIORef ret
 
-yesodRunner :: (ToTypedContent res, Yesod site)
+yesodRunner :: forall res site . (ToTypedContent res, Yesod site)
             => HandlerFor site res
             -> YesodRunnerEnv site
             -> Maybe (Route site)
@@ -312,7 +339,8 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
                   Left yreq' -> yreq'
                   Right needGen -> needGen yreGen
       let ra = resolveApproot yreSite req
-      let -- We set up two environments: the first one has a "safe" error handler
+      let log' = messageLoggerSource yreSite yreLogger
+          -- We set up two environments: the first one has a "safe" error handler
           -- which will never throw an exception. The second one uses the
           -- user-provided errorHandler function. If that errorHandler function
           -- errors out, it will use the safeEh below to recover.
@@ -323,9 +351,10 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
               , rheChild = yreSite
               , rheSite = yreSite
               , rheUpload = fileUpload yreSite
-              , rheLogFunc = yreLogFunc
-              , rheOnError = safeEh yreLogFunc
+              , rheLog = log'
+              , rheOnError = safeEh log'
               , rheMaxExpires = maxExpires
+              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite
               }
           rhe = rheSafe
               { rheOnError = runHandler rheSafe . errorHandler

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

@@ -1,10 +1,48 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
-module Yesod.Core.Internal.TH where
+{-# LANGUAGE RankNTypes #-}
+module Yesod.Core.Internal.TH
+    ( mkYesod
+    , mkYesodOpts
+
+    , mkYesodWith
+
+    , mkYesodData
+    , mkYesodDataOpts
+
+    , mkYesodSubData
+    , mkYesodSubDataOpts
+
+    , mkYesodWithParser
+    , mkYesodWithParserOpts
+
+    , mkYesodDispatch
+    , mkYesodDispatchOpts
+
+    , masterTypeSyns
+
+    , mkYesodGeneral
+    , mkYesodGeneralOpts
+
+    , mkMDS
+    , mkDispatchInstance
+
+    , mkYesodSubDispatch
+    
+    , subTopDispatch
+    , instanceD
+
+    , RouteOpts
+    , defaultOpts
+    , setEqDerived
+    , setShowDerived
+    , setReadDerived
+    )
+ where
 
 import Prelude hiding (exp)
 import Yesod.Core.Handler
@@ -22,6 +60,7 @@ import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
 
 import Yesod.Routes.TH
 import Yesod.Routes.Parse
+import Yesod.Core.Content (ToTypedContent (..))
 import Yesod.Core.Types
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
@@ -35,7 +74,17 @@ import Yesod.Core.Internal.Run
 mkYesod :: String -- ^ name of the argument datatype
         -> [ResourceTree String]
         -> Q [Dec]
-mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return
+mkYesod = mkYesodOpts defaultOpts
+
+-- | `mkYesod` but with custom options.
+--
+-- @since 1.6.25.0
+mkYesodOpts :: RouteOpts
+            -> String
+            -> [ResourceTree String]
+            -> Q [Dec]
+mkYesodOpts opts name = fmap (uncurry (++)) . mkYesodWithParserOpts opts name False return
+
 
 {-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}
 -- | Similar to 'mkYesod', except contexts and type variables are not parsed. 
@@ -48,15 +97,30 @@ mkYesodWith :: [[String]] -- ^ list of contexts
             -> Q [Dec]
 mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return
 
+
 -- | Sometimes, you will want to declare your routes in one file and define
 -- your handlers elsewhere. For example, this is the only way to break up a
 -- monolithic file into smaller parts. Use this function, paired with
 -- 'mkYesodDispatch', to do just that.
 mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodData name resS = fst <$> mkYesodWithParser name False return resS
+mkYesodData = mkYesodDataOpts defaultOpts
+
+-- | `mkYesodData` but with custom options.
+--
+-- @since 1.6.25.0
+mkYesodDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
+mkYesodDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name False return resS
+
 
 mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS
+mkYesodSubData = mkYesodSubDataOpts defaultOpts
+
+-- |
+--
+-- @since 1.6.25.0
+mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
+mkYesodSubDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name True return resS
+
 
 -- | Parses contexts and type arguments out of name before generating TH.
 mkYesodWithParser :: String                    -- ^ foundation type
@@ -64,11 +128,22 @@ mkYesodWithParser :: String                    -- ^ foundation type
                   -> (Exp -> Q Exp)            -- ^ unwrap handler
                   -> [ResourceTree String]
                   -> Q([Dec],[Dec])
-mkYesodWithParser name isSub f resS = do
+mkYesodWithParser = mkYesodWithParserOpts defaultOpts
+
+-- | Parses contexts and type arguments out of name before generating TH.
+--
+-- @since 1.6.25.0
+mkYesodWithParserOpts :: RouteOpts                 -- ^ Additional route options
+                      -> String                    -- ^ foundation type
+                      -> Bool                      -- ^ is this a subsite
+                      -> (Exp -> Q Exp)            -- ^ unwrap handler
+                      -> [ResourceTree String]
+                      -> Q([Dec],[Dec])
+mkYesodWithParserOpts opts name isSub f resS = do
     let (name', rest, cxt) = case parse parseName "" name of
             Left err -> error $ show err
             Right a -> a
-    mkYesodGeneral cxt name' rest isSub f resS
+    mkYesodGeneralOpts opts cxt name' rest isSub f resS
 
     where
         parseName = do
@@ -100,19 +175,28 @@ mkYesodWithParser name isSub f resS = do
         parseContexts = 
             sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
 
+
 -- | See 'mkYesodData'.
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodDispatch name = fmap snd . mkYesodWithParser name False return
+mkYesodDispatch = mkYesodDispatchOpts defaultOpts
+
+-- | See 'mkYesodDataOpts'
+--
+-- @since 1.6.25.0
+mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
+mkYesodDispatchOpts opts name = fmap snd . mkYesodWithParserOpts opts name False return
+
 
 -- | Get the Handler and Widget type synonyms for the given site.
 masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself?
 masterTypeSyns vs site =
-    [ TySynD (mkName "Handler") (fmap PlainTV vs)
+    [ TySynD (mkName "Handler") (fmap plainTV vs)
       $ ConT ''HandlerFor `AppT` site
-    , TySynD (mkName "Widget")  (fmap PlainTV vs)
+    , TySynD (mkName "Widget")  (fmap plainTV vs)
       $ ConT ''WidgetFor `AppT` site `AppT` ConT ''()
     ]
 
+
 mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
                -> String                    -- ^ foundation type
                -> [String]                  -- ^ arguments for the type
@@ -120,7 +204,20 @@ mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in Ren
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral appCxt' namestr mtys isSub f resS = do
+mkYesodGeneral = mkYesodGeneralOpts defaultOpts
+
+-- |
+--
+-- @since 1.6.25.0
+mkYesodGeneralOpts :: RouteOpts                 -- ^ Options to adjust route creation
+                   -> [[String]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
+                   -> String                    -- ^ foundation type
+                   -> [String]                  -- ^ arguments for the type
+                   -> Bool                      -- ^ is this a subsite
+                   -> (Exp -> Q Exp)            -- ^ unwrap handler
+                   -> [ResourceTree String]
+                   -> Q([Dec],[Dec])
+mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
     let appCxt = fmap (\(c:rest) -> 
             foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
           ) appCxt'
@@ -141,11 +238,14 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
     let name = mkName namestr
     -- Generate as many variable names as the arity indicates
     vns <- replicateM (arity - length mtys) $ newName "t"
-        -- Base type (site type with variables)
+    -- types that you apply to get a concrete site name
     let argtypes = fmap nameToType mtys ++ fmap VarT vns
-        site = foldl' AppT (ConT name) argtypes
+    -- typevars that should appear in synonym head
+    let argvars = (fmap mkName . filter isTvar) mtys ++ vns
+        -- Base type (site type with variables)
+    let site = foldl' AppT (ConT name) argtypes
         res = map (fmap (parseType . dropBracket)) resS
-    renderRouteDec <- mkRenderRouteInstance appCxt site res
+    renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res
     routeAttrsDec  <- mkRouteAttrsInstance appCxt site res
     dispatchDec    <- mkDispatchInstance site appCxt f res
     parseRoute <- mkParseRouteInstance appCxt site res
@@ -160,22 +260,15 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
             , renderRouteDec
             , [routeAttrsDec]
             , resourcesDec
-            , if isSub then [] else masterTypeSyns vns site
+            , if isSub then [] else masterTypeSyns argvars site
             ]
     return (dataDec, dispatchDec)
 
-mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
-mkMDS f rh = MkDispatchSettings
+
+mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
+mkMDS f rh sd = MkDispatchSettings
     { mdsRunHandler = rh
-    , mdsSubDispatcher =
-        [|\parentRunner getSub toParent env -> yesodSubDispatch
-                                 YesodSubRunnerEnv
-                                    { ysreParentRunner = parentRunner
-                                    , ysreGetSub = getSub
-                                    , ysreToParentRoute = toParent
-                                    , ysreParentEnv = env
-                                    }
-                              |]
+    , mdsSubDispatcher = sd
     , mdsGetPathInfo = [|W.pathInfo|]
     , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
     , mdsMethod = [|W.requestMethod|]
@@ -196,15 +289,35 @@ mkDispatchInstance :: Type                      -- ^ The master site type
                    -> [ResourceTree c]          -- ^ The resource
                    -> DecsQ
 mkDispatchInstance master cxt f res = do
-    clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res
+    clause' <- 
+        mkDispatchClause 
+            (mkMDS 
+                f 
+                [|yesodRunner|] 
+                [|\parentRunner getSub toParent env -> yesodSubDispatch
+                    YesodSubRunnerEnv
+                    { ysreParentRunner = parentRunner
+                    , ysreGetSub = getSub
+                    , ysreToParentRoute = toParent
+                    , ysreParentEnv = env
+                    }
+                |])
+            res
     let thisDispatch = FunD 'yesodDispatch [clause']
     return [instanceD cxt yDispatch [thisDispatch]]
   where
     yDispatch = ConT ''YesodDispatch `AppT` master
 
+
 mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
 mkYesodSubDispatch res = do
-    clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
+    clause' <- 
+        mkDispatchClause
+            (mkMDS 
+                return 
+                [|subHelper|] 
+                [|subTopDispatch|]) 
+        res
     inner <- newName "inner"
     let innerFun = FunD inner [clause']
     helper <- newName "helper"
@@ -216,5 +329,26 @@ mkYesodSubDispatch res = do
                 ]
     return $ LetE [fun] (VarE helper)
 
+
+subTopDispatch :: 
+    (YesodSubDispatch sub master) =>
+        (forall content. ToTypedContent content =>
+            SubHandlerFor child master content ->
+            YesodSubRunnerEnv child master ->
+            Maybe (Route child) ->
+            W.Application
+        ) ->
+        (mid -> sub) ->
+        (Route sub -> Route mid) ->
+        YesodSubRunnerEnv mid master ->
+        W.Application
+subTopDispatch _ getSub toParent env = yesodSubDispatch
+            (YesodSubRunnerEnv
+            { ysreParentRunner = ysreParentRunner env
+            , ysreGetSub = getSub . ysreGetSub env
+            , ysreToParentRoute = ysreToParentRoute env . toParent
+            , ysreParentEnv = ysreParentEnv env
+            })
+
 instanceD :: Cxt -> Type -> [Dec] -> Dec
 instanceD = InstanceD Nothing

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Yesod.Core.Json
     ( -- * Convert from a JSON value
       defaultLayoutJson
@@ -31,15 +32,18 @@ module Yesod.Core.Json
     , jsonOrRedirect
     , jsonEncodingOrRedirect
     , acceptsJson
+
+      -- * Checking if data is JSON
+    , contentTypeHeaderIsJson
     ) where
 
-import RIO
 import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)
 import Control.Monad.Trans.Writer (Writer)
 import Data.Monoid (Endo)
 import Yesod.Core.Content (TypedContent)
-import Yesod.Core.Types (reqAccept, HasHandlerData (..))
+import Yesod.Core.Types (reqAccept)
 import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
+import Yesod.Core.Class.Handler
 import Yesod.Core.Widget (WidgetFor)
 import Yesod.Routes.Class
 import qualified Data.Aeson as J
@@ -97,7 +101,7 @@ provideJson = provideRep . return . J.toEncoding
 -- | Same as 'parseInsecureJsonBody'
 --
 -- @since 0.3.0
-parseJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env (J.Result a)
+parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
 parseJsonBody = parseInsecureJsonBody
 {-# DEPRECATED parseJsonBody "Use parseCheckJsonBody or parseInsecureJsonBody instead" #-}
 
@@ -107,7 +111,7 @@ parseJsonBody = parseInsecureJsonBody
 -- Note: This function is vulnerable to CSRF attacks.
 --
 -- @since 1.6.11
-parseInsecureJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env (J.Result a)
+parseInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
 parseInsecureJsonBody = do
     eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')
     return $ case eValue of
@@ -130,22 +134,22 @@ parseInsecureJsonBody = do
 -- body will no longer be available.
 --
 -- @since 0.3.0
-parseCheckJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env (J.Result a)
+parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
 parseCheckJsonBody = do
     mct <- lookupHeader "content-type"
-    case fmap (B8.takeWhile (/= ';')) mct of
-        Just "application/json" -> parseInsecureJsonBody
+    case fmap contentTypeHeaderIsJson mct of
+        Just True -> parseInsecureJsonBody
         _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct
 
 -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
 -- error.
-parseJsonBody_ :: (HasHandlerData env, J.FromJSON a) => RIO env a
+parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
 parseJsonBody_ = requireInsecureJsonBody
 {-# DEPRECATED parseJsonBody_ "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}
 
 -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
 -- error.
-requireJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env a
+requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a
 requireJsonBody = requireInsecureJsonBody
 {-# DEPRECATED requireJsonBody "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}
 
@@ -153,7 +157,7 @@ requireJsonBody = requireInsecureJsonBody
 -- error.
 --
 -- @since 1.6.11
-requireInsecureJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env a
+requireInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m a
 requireInsecureJsonBody = do
     ra <- parseInsecureJsonBody
     case ra of
@@ -162,7 +166,7 @@ requireInsecureJsonBody = do
 
 -- | Same as 'parseCheckJsonBody', but return an invalid args response on a parse
 -- error.
-requireCheckJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env a
+requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a
 requireCheckJsonBody = do
     ra <- parseCheckJsonBody
     case ra of
@@ -180,10 +184,10 @@ array = J.Array . V.fromList . map J.toJSON
 --     @application\/json@ (e.g. AJAX, see 'acceptsJSON').
 --
 --     2. 3xx otherwise, following the PRG pattern.
-jsonOrRedirect :: (HasHandlerData env, J.ToJSON a)
-               => Route (HandlerSite env) -- ^ Redirect target
+jsonOrRedirect :: (MonadHandler m, J.ToJSON a)
+               => Route (HandlerSite m) -- ^ Redirect target
                -> a            -- ^ Data to send via JSON
-               -> RIO env J.Value
+               -> m J.Value
 jsonOrRedirect = jsonOrRedirect' J.toJSON
 
 -- | jsonEncodingOrRedirect simplifies the scenario where a POST handler sends a different
@@ -194,17 +198,17 @@ jsonOrRedirect = jsonOrRedirect' J.toJSON
 --
 --     2. 3xx otherwise, following the PRG pattern.
 -- @since 1.4.21
-jsonEncodingOrRedirect :: (HasHandlerData env, J.ToJSON a)
-            => Route (HandlerSite env) -- ^ Redirect target
+jsonEncodingOrRedirect :: (MonadHandler m, J.ToJSON a)
+            => Route (HandlerSite m) -- ^ Redirect target
             -> a            -- ^ Data to send via JSON
-            -> RIO env J.Encoding
+            -> m J.Encoding
 jsonEncodingOrRedirect = jsonOrRedirect' J.toEncoding
 
-jsonOrRedirect' :: HasHandlerData env
+jsonOrRedirect' :: MonadHandler m
             => (a -> b)
-            -> Route (HandlerSite env) -- ^ Redirect target
+            -> Route (HandlerSite m) -- ^ Redirect target
             -> a            -- ^ Data to send via JSON
-            -> RIO env b
+            -> m b
 jsonOrRedirect' f r j = do
     q <- acceptsJson
     if q then return (f j)
@@ -212,8 +216,17 @@ jsonOrRedirect' f r j = do
 
 -- | Returns @True@ if the client prefers @application\/json@ as
 -- indicated by the @Accept@ HTTP header.
-acceptsJson :: HasHandlerData env => RIO env Bool
+acceptsJson :: MonadHandler m => m Bool
 acceptsJson =  (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
             .  listToMaybe
             .  reqAccept)
            `liftM` getRequest
+
+-- | Given the @Content-Type@ header, returns if it is JSON.
+--
+-- This function is currently a simple check for @application/json@, but in the future may check for
+-- alternative representations such as @<https://tools.ietf.org/html/rfc6839#section-3.1 xxx/yyy+json>@.
+--
+-- @since 1.6.17
+contentTypeHeaderIsJson :: B8.ByteString -> Bool
+contentTypeHeaderIsJson bs = B8.takeWhile (/= ';') bs == "application/json"

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

@@ -1,51 +1,62 @@
-{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE QuantifiedConstraints #-}
--- FIXME rename to Internal
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
 module Yesod.Core.Types where
 
+import Data.Aeson (ToJSON)
 import qualified Data.ByteString.Builder            as BB
-import           Control.Monad.Trans.Resource       (ResourceT)
+import           Control.Arrow                      (first)
+import           Control.Exception                  (Exception)
+import           Control.Monad                      (ap)
+import           Control.Monad.IO.Class             (MonadIO (liftIO))
+import           Control.Monad.Logger               (LogLevel, LogSource,
+                                                     MonadLogger (..))
+import           Control.Monad.Primitive            (PrimMonad (..))
+import           Control.Monad.Trans.Resource       (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)
+import           Data.ByteString                    (ByteString)
 import qualified Data.ByteString.Lazy               as L
 import           Data.CaseInsensitive               (CI)
-import           Conduit                            (Flush, ConduitT)
-import           RIO.Map                            (unionWith)
-import qualified RIO.Map                            as Map
+import           Data.Conduit                       (Flush, ConduitT)
+import           Data.IORef                         (IORef, modifyIORef')
+import           Data.Map                           (Map, unionWith)
+import qualified Data.Map                           as Map
 import           Data.Monoid                        (Endo (..), Last (..))
+import           Data.Semigroup                     (Semigroup(..))
 import           Data.Serialize                     (Serialize (..),
                                                      putByteString)
 import           Data.String                        (IsString (fromString))
+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
 import           Network.Wai                        (FilePart,
                                                      RequestBodyLength)
 import qualified Network.Wai                        as W
 import qualified Network.Wai.Parse                  as NWP
+import           System.Log.FastLogger              (LogStr, LoggerSet, toLogStr, pushLogStr)
+import           Network.Wai.Logger                 (DateCacheGetter)
 import           Text.Blaze.Html                    (Html, toHtml)
 import           Text.Hamlet                        (HtmlUrl)
 import           Text.Julius                        (JavascriptUrl)
 import           Web.Cookie                         (SetCookie)
 import           Yesod.Core.Internal.Util           (getTime, putTime)
 import           Yesod.Routes.Class                 (RenderRoute (..), ParseRoute (..))
+import           Control.Monad.Reader               (MonadReader (..))
 import Control.DeepSeq (NFData (rnf))
 import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
-
-import RIO
-import RIO.Orphans
+import Control.Monad.Logger (MonadLoggerIO (..))
+import UnliftIO (MonadUnliftIO (..), SomeException)
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -121,7 +132,7 @@ data FileInfo = FileInfo
     }
 
 data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
-                | FileUploadDisk !(ResourceMap -> NWP.BackEnd FilePath)
+                | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)
                 | FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ()))
 
 -- | How to determine the root of the application for constructing URLs.
@@ -166,73 +177,39 @@ data RunHandlerEnv child site = RunHandlerEnv
     , rheSite     :: !site
     , rheChild    :: !child
     , rheUpload   :: !(RequestBodyLength -> FileUpload)
-    , rheLogFunc  :: !LogFunc
+    , rheLog      :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
     , rheOnError  :: !(ErrorResponse -> YesodApp)
       -- ^ How to respond when an error is thrown internally.
       --
       -- Since 1.2.0
     , rheMaxExpires :: !Text
-    }
-instance HasLogFunc (RunHandlerEnv child site) where
-  logFuncL = lens rheLogFunc (\x y -> x { rheLogFunc = y })
 
-data SubHandlerData child site = SubHandlerData
+      -- | @since 1.6.24.0
+      --   catch function for rendering 500 pages on exceptions.
+      --   by default this is catch from unliftio (rethrows all async exceptions).
+    , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m =>  m a -> (SomeException -> m a) -> m a)
+    }
+
+data HandlerData child site = HandlerData
     { handlerRequest  :: !YesodRequest
     , handlerEnv      :: !(RunHandlerEnv child site)
     , handlerState    :: !(IORef GHState)
-    , handlerResource :: !ResourceMap
+    , handlerResource :: !InternalState
     }
 
-class (HasResourceMap env, HasLogFunc env) => HasHandlerData env where
-  type HandlerSite env
-  type SubHandlerSite env
-
-  subHandlerDataL :: Lens' env (SubHandlerData (SubHandlerSite env) (HandlerSite env))
-class (HasHandlerData env, HandlerSite env ~ SubHandlerSite env) => HasWidgetData env where
-  widgetDataL :: Lens' env (WidgetData (HandlerSite env))
-
-instance HasHandlerData (SubHandlerData child site) where
-  type HandlerSite (SubHandlerData child site) = site
-  type SubHandlerSite (SubHandlerData child site) = child
-  subHandlerDataL = id
-instance HasLogFunc (SubHandlerData child site) where
-  logFuncL = lens handlerEnv (\x y -> x { handlerEnv = y }).logFuncL
-instance HasResourceMap (SubHandlerData child site) where
-  resourceMapL = lens handlerResource (\x y -> x { handlerResource = y })
-
-instance HasHandlerData (HandlerData site) where
-  type HandlerSite (HandlerData site) = site
-  type SubHandlerSite (HandlerData site) = site
-  subHandlerDataL = lens unHandlerData (\_ y -> HandlerData y)
-instance HasLogFunc (HandlerData site) where
-  logFuncL = subHandlerDataL.logFuncL
-instance HasResourceMap (HandlerData site) where
-  resourceMapL = subHandlerDataL.resourceMapL
-
-instance HasHandlerData (WidgetData site) where
-  type HandlerSite (WidgetData site) = site
-  type SubHandlerSite (WidgetData site) = site
-  subHandlerDataL =
-    (lens wdHandler (\x y -> x { wdHandler = y })).subHandlerDataL
-instance HasWidgetData (WidgetData site) where
-  widgetDataL = id
-instance HasLogFunc (WidgetData site) where
-  logFuncL = subHandlerDataL.logFuncL
-instance HasResourceMap (WidgetData site) where
-  resourceMapL = subHandlerDataL.resourceMapL
-
-newtype HandlerData site = HandlerData { unHandlerData :: SubHandlerData site site }
-
 data YesodRunnerEnv site = YesodRunnerEnv
-    { yreLogFunc        :: !LogFunc
+    { yreLogger         :: !Logger
     , 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)
-    , yreCleanup        :: !(IORef ())
-    -- ^ Used to ensure some cleanup actions can be performed via
-    -- garbage collection.
     }
 
 data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv
@@ -250,7 +227,10 @@ type ParentRunner parent
 
 -- | A generic handler monad, which can have a different subsite and master
 -- site. We define a newtype for better error message.
-type HandlerFor site = RIO (HandlerData site)
+newtype HandlerFor site a = HandlerFor
+    { unHandlerFor :: HandlerData site site -> IO a
+    }
+    deriving Functor
 
 data GHState = GHState
     { ghsSession :: !SessionMap
@@ -263,19 +243,30 @@ 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
 -- site datatypes. While this is simply a @WriterT@, we define a newtype for
 -- better error messages.
-type WidgetFor site = RIO (WidgetData site)
+newtype WidgetFor site a = WidgetFor
+    { unWidgetFor :: WidgetData site -> IO a
+    }
+    deriving Functor
 
 data WidgetData site = WidgetData
   { wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))
-  , wdHandler :: {-# UNPACK #-} !(HandlerData site)
+  , wdHandler :: {-# UNPACK #-} !(HandlerData site site)
   }
 
+instance a ~ () => Monoid (WidgetFor site a) where
+    mempty = return ()
+#if !(MIN_VERSION_base(4,11,0))
+    mappend = (<>)
+#endif
+instance a ~ () => Semigroup (WidgetFor site a) where
+    x <> y = x >> y
+
 -- | A 'String' can be trivially promoted to a widget.
 --
 -- For example, in a yesod-scaffold site you could use:
@@ -285,10 +276,8 @@ instance a ~ () => IsString (WidgetFor site a) where
     fromString = toWidget . toHtml . T.pack
       where toWidget x = tellWidget mempty { gwdBody = Body (const x) }
 
-tellWidget :: HasWidgetData env => GWData (Route (HandlerSite env)) -> RIO env ()
-tellWidget d = do
-  wd <- view widgetDataL
-  modifyIORef' (wdRef wd) (<> d)
+tellWidget :: GWData (Route site) -> WidgetFor site ()
+tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d)
 
 type RY master = Route master -> [(Text, Text)] -> Text
 
@@ -306,13 +295,14 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
 --
 -- > PageContent url -> HtmlUrl url
 data PageContent url = PageContent
-    { pageTitle :: !Html
-    , pageHead  :: !(HtmlUrl url)
-    , pageBody  :: !(HtmlUrl url)
+    { pageTitle       :: !Html
+    , pageDescription :: !(Maybe Text)
+    , pageHead        :: !(HtmlUrl url)
+    , pageBody        :: !(HtmlUrl url)
     }
 
-data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length.
-             | ContentSource !(ConduitT () (Flush Builder) (ResourceT IO) ())
+data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
+             | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())
              | ContentFile !FilePath !(Maybe FilePart)
              | ContentDontEvaluate !Content
 
@@ -326,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.
 --
@@ -335,12 +339,29 @@ 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.)
+        -- HTTP code: 405.
+    deriving (Show, Eq, Generic)
 instance NFData ErrorResponse
 
 ----- header stuff
@@ -353,6 +374,9 @@ data Header =
     -- ^ key and value
     deriving (Eq, Show)
 
+-- FIXME In the next major version bump, let's just add strictness annotations
+-- to Header (and probably everywhere else). We can also add strictness
+-- annotations to SetCookie in the cookie package.
 instance NFData Header where
     rnf (AddCookie x) = rnf x
     rnf (DeleteCookie x y) = x `seq` y `seq` ()
@@ -370,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
@@ -385,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
@@ -392,18 +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 b1 b2 b3 b4 b5 b6 b7 = GWData
+    GWData a1 a2 a3 a4 a5 a6 a7 a8 <>
+      GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData
         (mappend a1 b1)
         (mappend a2 b2)
         (mappend a3 b3)
         (mappend a4 b4)
-        (unionWith mappend a5 b5)
-        (mappend a6 b6)
+        (mappend a5 b5)
+        (unionWith mappend a6 b6)
         (mappend a7 b7)
+        (mappend a8 b8)
 
 data HandlerContents =
       HCContent !H.Status !TypedContent
@@ -413,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)
@@ -425,9 +453,82 @@ instance Show HandlerContents where
     show (HCWaiApp _) = "HCWaiApp"
 instance Exception HandlerContents
 
+-- Instances for WidgetFor
+instance Applicative (WidgetFor site) where
+    pure = WidgetFor . const . pure
+    (<*>) = ap
+instance Monad (WidgetFor site) where
+    return = pure
+    WidgetFor x >>= f = WidgetFor $ \wd -> do
+        a <- x wd
+        unWidgetFor (f a) wd
+instance MonadIO (WidgetFor site) where
+    liftIO = WidgetFor . const
+-- | @since 1.6.7
+instance PrimMonad (WidgetFor site) where
+    type PrimState (WidgetFor site) = PrimState IO
+    primitive = liftIO . primitive
+-- | @since 1.4.38
+instance MonadUnliftIO (WidgetFor site) where
+  {-# INLINE withRunInIO #-}
+  withRunInIO inner = WidgetFor $ \x -> inner $ flip unWidgetFor x
+instance MonadReader (WidgetData site) (WidgetFor site) where
+    ask = WidgetFor return
+    local f (WidgetFor g) = WidgetFor $ g . f
+
+instance MonadThrow (WidgetFor site) where
+    throwM = liftIO . throwM
+
+instance MonadResource (WidgetFor site) where
+    liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler
+
+instance MonadLogger (WidgetFor site) where
+    monadLoggerLog a b c d = WidgetFor $ \wd ->
+        rheLog (handlerEnv $ wdHandler wd) a b c (toLogStr d)
+
+instance MonadLoggerIO (WidgetFor site) where
+    askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
+
+-- Instances for HandlerFor
+instance Applicative (HandlerFor site) where
+    pure = HandlerFor . const . return
+    (<*>) = ap
+instance Monad (HandlerFor site) where
+    return = pure
+    HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r
+instance MonadIO (HandlerFor site) where
+    liftIO = HandlerFor . const
+-- | @since 1.6.7
+instance PrimMonad (HandlerFor site) where
+    type PrimState (HandlerFor site) = PrimState IO
+    primitive = liftIO . primitive
+instance MonadReader (HandlerData site site) (HandlerFor site) where
+    ask = HandlerFor return
+    local f (HandlerFor g) = HandlerFor $ g . f
+
+-- | @since 1.4.38
+instance MonadUnliftIO (HandlerFor site) where
+  {-# INLINE withRunInIO #-}
+  withRunInIO inner = HandlerFor $ \x -> inner $ flip unHandlerFor x
+
+instance MonadThrow (HandlerFor site) where
+    throwM = liftIO . throwM
+
+instance MonadResource (HandlerFor site) where
+    liftResourceT f = HandlerFor $ runInternalState f . handlerResource
+
+instance MonadLogger (HandlerFor site) where
+    monadLoggerLog a b c d = HandlerFor $ \hd ->
+        rheLog (handlerEnv hd) a b c (toLogStr d)
+
+instance MonadLoggerIO (HandlerFor site) where
+    askLoggerIO = HandlerFor $ \hd -> return (rheLog (handlerEnv hd))
+
 instance Monoid (UniqueList x) where
     mempty = UniqueList id
+#if !(MIN_VERSION_base(4,11,0))
     mappend = (<>)
+#endif
 instance Semigroup (UniqueList x) where
     UniqueList x <> UniqueList y = UniqueList $ x . y
 
@@ -449,34 +550,48 @@ instance RenderRoute WaiSubsiteWithAuth where
 instance ParseRoute WaiSubsiteWithAuth where
   parseRoute (x, y) = Just $ WaiSubsiteWithAuthRoute x y
 
+data Logger = Logger
+    { loggerSet :: !LoggerSet
+    , loggerDate :: !DateCacheGetter
+    }
+
+loggerPutStr :: Logger -> LogStr -> IO ()
+loggerPutStr (Logger ls _) = pushLogStr ls
+
 -- | A handler monad for subsite
 --
 -- @since 1.6.0
-type SubHandlerFor sub master = RIO (SubHandlerData sub master)
+newtype SubHandlerFor sub master a = SubHandlerFor
+    { unSubHandlerFor :: HandlerData sub master -> IO a
+    }
+    deriving Functor
 
--- | Convert a concrete 'HandlerFor' action into an arbitrary other monad.
-liftHandler
-  :: (MonadIO m, MonadReader env m, HasHandlerData env)
-  => HandlerFor (HandlerSite env) a
-  -> m a
-liftHandler action = do
-  shd <- view subHandlerDataL
-  let hd = HandlerData $ shd
-            { handlerEnv =
-                let rhe = handlerEnv shd
-                 in rhe
-                      { rheRoute = rheRouteToMaster rhe <$> rheRoute rhe
-                      , rheChild = rheSite rhe
-                      , rheRouteToMaster = id
-                      }
-            }
-  runRIO hd action
+instance Applicative (SubHandlerFor child master) where
+    pure = SubHandlerFor . const . return
+    (<*>) = ap
+instance Monad (SubHandlerFor child master) where
+    return = pure
+    SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r
+instance MonadIO (SubHandlerFor child master) where
+    liftIO = SubHandlerFor . const
+instance MonadReader (HandlerData child master) (SubHandlerFor child master) where
+    ask = SubHandlerFor return
+    local f (SubHandlerFor g) = SubHandlerFor $ g . f
 
--- | Convert a concrete 'WidgetFor' action into an arbitrary other monad.
-liftWidget
-  :: (MonadIO m, MonadReader env m, HasWidgetData env)
-  => WidgetFor (HandlerSite env) a
-  -> m a
-liftWidget action = do
-  hd <- view widgetDataL
-  runRIO hd action
+-- | @since 1.4.38
+instance MonadUnliftIO (SubHandlerFor child master) where
+  {-# INLINE withRunInIO #-}
+  withRunInIO inner = SubHandlerFor $ \x -> inner $ flip unSubHandlerFor x
+
+instance MonadThrow (SubHandlerFor child master) where
+    throwM = liftIO . throwM
+
+instance MonadResource (SubHandlerFor child master) where
+    liftResourceT f = SubHandlerFor $ runInternalState f . handlerResource
+
+instance MonadLogger (SubHandlerFor child master) where
+    monadLoggerLog a b c d = SubHandlerFor $ \sd ->
+        rheLog (handlerEnv sd) a b c (toLogStr d)
+
+instance MonadLoggerIO (SubHandlerFor child master) where
+    askLoggerIO = SubHandlerFor $ return . rheLog . handlerEnv

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
 -- | This is designed to be used as
 --
 -- > import qualified Yesod.Core.Unsafe as Unsafe
@@ -6,21 +5,21 @@
 -- This serves as a reminder that the functions are unsafe to use in many situations.
 module Yesod.Core.Unsafe (runFakeHandler, fakeHandlerGetLogger) where
 
-import RIO
 import Yesod.Core.Internal.Run (runFakeHandler)
 
 import Yesod.Core.Types
 import Yesod.Core.Class.Yesod
+import Control.Monad.IO.Class (MonadIO)
 
 -- | designed to be used as
 --
 -- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 fakeHandlerGetLogger :: (Yesod site, MonadIO m)
-                     => LogFunc
+                     => (site -> Logger)
                      -> site
                      -> HandlerFor site a
                      -> m a
-fakeHandlerGetLogger logFunc app f =
-     runFakeHandler mempty logFunc app f
+fakeHandlerGetLogger getLogger app f =
+     runFakeHandler mempty getLogger app f
  >>= either (error . ("runFakeHandler issue: " `mappend`) . show)
             return

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

@@ -6,9 +6,10 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# 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
@@ -58,7 +65,9 @@ import Text.Julius
 import Yesod.Routes.Class
 import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
 import Text.Shakespeare.I18N (RenderMessage)
-import qualified RIO.Map as Map
+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)
 
@@ -68,32 +77,32 @@ import Text.Blaze.Html (toHtml, preEscapedToMarkup)
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TB
 
-import RIO
 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
 preEscapedLazyText = preEscapedToMarkup
 
 class ToWidget site a where
-    toWidget :: (HasWidgetData env, HandlerSite env ~ site) => a -> RIO env ()
+    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
@@ -115,21 +124,21 @@ class ToWidgetMedia site a where
     -- | Add the given content to the page, but only for the given media type.
     --
     -- Since 1.2
-    toWidgetMedia :: (HasWidgetData env, HandlerSite env ~ site)
+    toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site)
                   => Text -- ^ media value
                   -> a
-                  -> RIO env ()
+                  -> m ()
 instance render ~ RY site => ToWidgetMedia site (render -> Css) where
     toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
 instance ToWidgetMedia site Css where
     toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x
 instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
-    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (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 :: (HasWidgetData env, HandlerSite env ~ site) => a -> RIO env ()
+    toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
 
 instance render ~ RY site => ToWidgetBody site (render -> Html) where
     toWidgetBody = toWidget
@@ -141,10 +150,10 @@ instance ToWidgetBody site Html where
     toWidgetBody = toWidget
 
 class ToWidgetHead site a where
-    toWidgetHead :: (HasWidgetData env, HandlerSite env ~ site) => a -> RIO env ()
+    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
@@ -160,62 +169,177 @@ instance ToWidgetHead site Javascript where
 instance ToWidgetHead site Html where
     toWidgetHead = toWidgetHead . const
 
--- | Set the page title. Calling 'setTitle' multiple times overrides previously
--- set values.
-setTitle :: HasWidgetData env => Html -> RIO env ()
-setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
+-- | Set the page title.
+--
+-- Calling @setTitle@ or @setTitleI@ multiple times overrides previously set
+-- values.
+--
+-- SEO Notes:
+--
+--    * Title tags are the second most important on-page factor for SEO, after
+--      content
+--    * Every page should have a unique title tag
+--    * Start your title tag with your main targeted keyword
+--    * Don't stuff your keywords
+--    * Google typically shows 55-64 characters, so aim to keep your title
+--      length under 60 characters
+setTitle :: MonadWidget m => Html -> m ()
+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty
 
--- | Set the page title. Calling 'setTitle' multiple times overrides previously
--- set values.
-setTitleI :: (HasWidgetData env, RenderMessage (HandlerSite env) msg) => msg -> RIO env ()
+-- | Set the localised page title.
+--
+-- n.b. See comments for @setTitle@
+setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
 setTitleI msg = do
     mr <- getMessageRender
     setTitle $ toHtml $ mr msg
 
+-- | Add description meta tag to the head of the page
+--
+-- Google does not use the description tag as a ranking signal, but the
+-- contents of this tag will likely affect your click-through rate since it
+-- shows up in search results.
+--
+-- The average length of the description shown in Google's search results is
+-- about 160 characters on desktop, and about 130 characters on mobile, at time
+-- of writing.
+--
+-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
+--
+-- @since 1.6.18
+setDescription :: MonadWidget m => Text -> m ()
+setDescription description =
+    toWidgetHead $ [hamlet|<meta name=description content=#{description}>|]
+
+{-# WARNING setDescription
+  [ "setDescription is not idempotent; we recommend setDescriptionIdemp instead"
+  , "Multiple calls to setDescription will insert multiple meta tags in the page head."
+  , "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \
+    \may need to change your layout to include pageDescription."
+  ]
+#-}
+
+-- | Add translated description meta tag to the head of the page
+--
+-- n.b. See comments for @setDescription@.
+--
+-- @since 1.6.18
+setDescriptionI
+  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)
+  => msg -> m ()
+setDescriptionI msg = do
+    mr <- getMessageRender
+    toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|]
+
+{-# WARNING setDescriptionI
+  [ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead"
+  , "Multiple calls to setDescriptionI will insert multiple meta tags in the page head."
+  , "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \
+    \may need to change your layout to include pageDescription."
+  ]
+#-}
+
+-- | Add description meta tag to the head of the page
+--
+-- Google does not use the description tag as a ranking signal, but the
+-- contents of this tag will likely affect your click-through rate since it
+-- shows up in search results.
+--
+-- The average length of the description shown in Google's search results is
+-- about 160 characters on desktop, and about 130 characters on mobile, at time
+-- of writing.
+--
+-- Unlike 'setDescription', this version is *idempotent* - calling it multiple
+-- times will result in only a single description meta tag in the head.
+--
+-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
+--
+-- @since 1.6.23
+setDescriptionIdemp :: MonadWidget m => Text -> m ()
+setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty
+
+-- | Add translated description meta tag to the head of the page
+--
+-- n.b. See comments for @setDescriptionIdemp@.
+--
+-- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple
+-- times will result in only a single description meta tag in the head.
+--
+-- @since 1.6.23
+setDescriptionIdempI
+  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)
+  => msg -> m ()
+setDescriptionIdempI msg = do
+    mr <- getMessageRender
+    setDescriptionIdemp $ mr msg
+
+-- | Add OpenGraph type meta tag to the head of the page
+--
+-- See all available OG types here: https://ogp.me/#types
+--
+-- @since 1.6.18
+setOGType :: MonadWidget m => Text -> m ()
+setOGType a = toWidgetHead $ [hamlet|<meta property="og:type" content=#{a}>|]
+
+-- | Add OpenGraph image meta tag to the head of the page
+--
+-- Best practices:
+--
+--    * Use custom images for shareable pages, e.g., homepage, articles, etc.
+--    * Use your logo or any other branded image for the rest of your pages.
+--    * Use images with a 1.91:1 ratio and minimum recommended dimensions of
+--      1200x630 for optimal clarity across all devices.
+--
+-- Source: https://ahrefs.com/blog/open-graph-meta-tags/
+--
+-- @since 1.6.18
+setOGImage :: MonadWidget m => Text -> m ()
+setOGImage a = toWidgetHead $ [hamlet|<meta property="og:image" content=#{a}>|]
+
 -- | Link to the specified local stylesheet.
-addStylesheet :: HasWidgetData env => Route (HandlerSite env) -> RIO env ()
+addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
 addStylesheet = flip addStylesheetAttrs []
 
 -- | Link to the specified local stylesheet.
-addStylesheetAttrs :: HasWidgetData env
-                   => Route (HandlerSite env)
+addStylesheetAttrs :: MonadWidget m
+                   => Route (HandlerSite m)
                    -> [(Text, Text)]
-                   -> RIO env ()
-addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
+                   -> m ()
+addStylesheetAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
 
 -- | Link to the specified remote stylesheet.
-addStylesheetRemote :: HasWidgetData env => Text -> RIO env ()
+addStylesheetRemote :: MonadWidget m => Text -> m ()
 addStylesheetRemote = flip addStylesheetRemoteAttrs []
 
 -- | Link to the specified remote stylesheet.
-addStylesheetRemoteAttrs :: HasWidgetData env => Text -> [(Text, Text)] -> RIO env ()
-addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
+addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
+addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
 
-addStylesheetEither :: HasWidgetData env
-                    => Either (Route (HandlerSite env)) Text
-                    -> RIO env ()
+addStylesheetEither :: MonadWidget m
+                    => Either (Route (HandlerSite m)) Text
+                    -> m ()
 addStylesheetEither = either addStylesheet addStylesheetRemote
 
-addScriptEither :: HasWidgetData env
-                => Either (Route (HandlerSite env)) Text
-                -> RIO env ()
+addScriptEither :: MonadWidget m
+                => Either (Route (HandlerSite m)) Text
+                -> m ()
 addScriptEither = either addScript addScriptRemote
 
 -- | Link to the specified local script.
-addScript :: HasWidgetData env => Route (HandlerSite env) -> RIO env ()
+addScript :: MonadWidget m => Route (HandlerSite m) -> m ()
 addScript = flip addScriptAttrs []
 
 -- | Link to the specified local script.
-addScriptAttrs :: HasWidgetData env => Route (HandlerSite env) -> [(Text, Text)] -> RIO env ()
-addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
+addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()
+addScriptAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
 
 -- | Link to the specified remote script.
-addScriptRemote :: HasWidgetData env => Text -> RIO env ()
+addScriptRemote :: MonadWidget m => Text -> m ()
 addScriptRemote = flip addScriptRemoteAttrs []
 
 -- | Link to the specified remote script.
-addScriptRemoteAttrs :: HasWidgetData env => Text -> [(Text, Text)] -> RIO env ()
-addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
+addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
+addScriptRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
 
 whamlet :: QuasiQuoter
 whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
@@ -247,28 +371,28 @@ rules = do
     return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
 
 -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
-ihamletToRepHtml :: (HasHandlerData env, RenderMessage (HandlerSite env) message)
-                 => HtmlUrlI18n message (Route (HandlerSite env))
-                 -> RIO env Html
+ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
+                 => HtmlUrlI18n message (Route (HandlerSite m))
+                 -> m Html
 ihamletToRepHtml = ihamletToHtml
 {-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-}
 
 -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
 --
 -- Since 1.2.1
-ihamletToHtml :: (HasHandlerData env, RenderMessage (HandlerSite env) message)
-              => HtmlUrlI18n message (Route (HandlerSite env))
-              -> RIO env Html
+ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
+              => HtmlUrlI18n message (Route (HandlerSite m))
+              -> m Html
 ihamletToHtml ih = do
     urender <- getUrlRenderParams
     mrender <- getMessageRender
     return $ ih (toHtml . mrender) urender
 
-tell :: HasWidgetData env => GWData (Route (HandlerSite env)) -> RIO env ()
+tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
 tell = liftWidget . tellWidget
 
 toUnique :: x -> UniqueList x
 toUnique = UniqueList . (:)
 
 handlerToWidget :: HandlerFor site a -> WidgetFor site a
-handlerToWidget = liftHandler
+handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler

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
 
@@ -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 = ConT $ mkName t
+nameToType t = if isTvar t
+               then VarT $ mkName t
+               else ConT $ mkName t
+
+isTvar :: String -> Bool
+isTvar (h:_) = isLower h
+isTvar _     = False
 
 pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
 pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)

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

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

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

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

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

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

yesod-core/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

@@ -227,7 +227,7 @@ main = hspec $ do
     describe "routing table parsing" $ do
         it "recognizes trailing backslashes as line continuation directives" $ do
             let routes :: [ResourceTree String]
-                routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations")
+                routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations.yesodroutes")
             length routes @?= 3
 
     describe "overlap checking" $ do

yesod-core/test/YesodCoreTest.hs

@@ -5,12 +5,16 @@ import YesodCoreTest.CleanPath
 import YesodCoreTest.Exceptions
 import YesodCoreTest.Widget
 import YesodCoreTest.Media
+import YesodCoreTest.Meta
 import YesodCoreTest.Links
 import YesodCoreTest.Header
 import YesodCoreTest.NoOverloadedStrings
+import YesodCoreTest.SubSub
 import YesodCoreTest.InternalRequest
 import YesodCoreTest.ErrorHandling
 import YesodCoreTest.Cache
+import YesodCoreTest.ParameterizedSite
+import YesodCoreTest.Breadcrumb
 import qualified YesodCoreTest.WaiSubsite as WaiSubsite
 import qualified YesodCoreTest.Redirect as Redirect
 import qualified YesodCoreTest.JsLoader as JsLoader
@@ -40,9 +44,11 @@ specs = do
       mediaTest
       linksTest
       noOverloadedTest
+      subSubTest
       internalRequestTest
       errorHandlingTest
       cacheTest
+      parameterizedSiteTest
       WaiSubsite.specs
       Redirect.specs
       JsLoader.specs
@@ -59,3 +65,5 @@ specs = do
       Ssl.sslOnlySpec
       Ssl.sameSiteSpec
       Csrf.csrfSpec
+      breadcrumbTest
+      metaTest

yesod-core/test/YesodCoreTest/Breadcrumb.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module YesodCoreTest.Breadcrumb
+  ( breadcrumbTest,
+  )
+where
+
+import qualified Data.ByteString.Lazy.Char8 as L8
+import Data.Text (Text)
+import Data.Typeable (Typeable)
+import Network.Wai
+import Network.Wai.Test
+import Test.Hspec
+import UnliftIO.IORef
+import Yesod.Core
+
+data A = A
+
+mkYesod
+  "A"
+  [parseRoutes|
+/    RootR GET
+/loop LoopR GET
+|]
+
+instance Yesod A
+
+instance YesodBreadcrumbs A where
+  breadcrumb r = case r of
+    RootR -> pure ("Root", Nothing)
+    LoopR -> pure ("Loop", Just LoopR) -- Purposefully a loop
+
+getRootR :: Handler Text
+getRootR = fst <$> breadcrumbs
+
+getLoopR :: Handler Text
+getLoopR = fst <$> breadcrumbs
+
+breadcrumbTest :: Spec
+breadcrumbTest =
+  describe "Test.Breadcrumb" $ do
+    it "can fetch the root which contains breadcrumbs" $
+      runner $ do
+        res <- request defaultRequest
+        assertStatus 200 res
+    it "gets a 500 for a route with a looping breadcrumb" $
+      runner $ do
+        res <- request defaultRequest {pathInfo = ["loop"]}
+        assertStatus 500 res
+
+runner :: Session () -> IO ()
+runner f = toWaiApp A >>= runSession f

yesod-core/test/YesodCoreTest/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

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -1,26 +1,37 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+
 module YesodCoreTest.ErrorHandling
     ( errorHandlingTest
     , Widget
     , resourcesApp
     ) where
+
+import  Data.Typeable(cast)
+import qualified System.Mem as Mem
+import qualified Control.Concurrent.Async as Async
+import Control.Concurrent as Conc
 import Yesod.Core
 import Test.Hspec
 import Network.Wai
 import Network.Wai.Test
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Char8 as S8
-import Control.Exception (SomeException, try)
+import Control.Exception (SomeException, try, AsyncException(..))
+import           UnliftIO.Exception(finally)
 import Network.HTTP.Types (Status, mkStatus)
 import Data.ByteString.Builder (Builder, toLazyByteString)
 import Data.Monoid (mconcat)
 import Data.Text (Text, pack)
 import Control.Monad (forM_)
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom
 import Control.Monad.Trans.State (StateT (..))
 import Control.Monad.Trans.Reader (ReaderT (..))
 import qualified UnliftIO.Exception as E
+import System.Timeout(timeout)
 
 data App = App
 
@@ -45,6 +56,10 @@ mkYesod "App" [parseRoutes|
 /auth-not-adequate AuthNotAdequateR GET
 /args-not-valid ArgsNotValidR POST
 /only-plain-text OnlyPlainTextR GET
+
+/thread-killed ThreadKilledR GET
+/connection-closed-by-peer ConnectionClosedPeerR GET
+/sleep-sec SleepASecR GET
 |]
 
 overrideStatus :: Status
@@ -56,7 +71,7 @@ instance Yesod App where
 
 getHomeR :: Handler Html
 getHomeR = do
-    logDebug "Testing logging"
+    $logDebug "Testing logging"
     defaultLayout $ toWidget [hamlet|
 $doctype 5
 
@@ -111,6 +126,23 @@ goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n"
 getGoodBuilderR :: Handler TypedContent
 getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
 
+-- this handler kills it's own thread
+getThreadKilledR :: Handler Html
+getThreadKilledR = do
+  x <- liftIO Conc.myThreadId
+  liftIO $ Async.withAsync (Conc.killThread x) Async.wait
+  pure "unreachablle"
+getSleepASecR :: Handler Html
+getSleepASecR = do
+  liftIO $ Conc.threadDelay 1000000
+  pure "slept a second"
+
+getConnectionClosedPeerR :: Handler Html
+getConnectionClosedPeerR = do
+  x <- liftIO Conc.myThreadId
+  liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait
+  pure "unreachablle"
+
 getErrorR :: Int -> Handler ()
 getErrorR 1 = setSession undefined "foo"
 getErrorR 2 = setSession "foo" undefined
@@ -154,6 +186,10 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "accept CSS, permission denied -> 403" caseCssPermissionDenied
       it "accept image, non-existent path -> 404" caseImageNotFound
       it "accept video, bad method -> 405" caseVideoBadMethod
+      it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows
+      it "custom config rethrows an exception" caseCustomExceptionRethrows
+      it "thread killed rethrow" caseThreadKilledRethrow
+      it "can timeout a runner" canTimeoutARunner
 
 runner :: Session a -> IO a
 runner f = toWaiApp App >>= runSession f
@@ -291,3 +327,50 @@ caseVideoBadMethod = runner $ do
                 ("accept", "video/webm") : requestHeaders defaultRequest
             }
     assertStatus 405 res
+
+fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e
+fromExceptionUnwrap se
+  | Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e
+  | Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e
+  | otherwise = E.fromException se
+
+
+caseThreadKilledRethrow :: IO ()
+caseThreadKilledRethrow =
+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
+                                (Just ThreadKilled) -> True
+                                _ -> False
+  where
+  testcode = runner $ do
+                res <- request defaultRequest { pathInfo = ["thread-killed"] }
+                assertStatus 500 res
+                assertBodyContains "Internal Server Error" res
+
+caseDefaultConnectionCloseRethrows :: IO ()
+caseDefaultConnectionCloseRethrows =
+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
+                                  Just Warp.ConnectionClosedByPeer -> True
+                                  _ -> False
+
+  where
+  testcode = runner $ do
+      _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] }
+      pure ()
+
+caseCustomExceptionRethrows :: IO ()
+caseCustomExceptionRethrows =
+  shouldThrow testcode $ \case Custom.MkMyException -> True
+  where
+    testcode = customAppRunner $ do
+      _res <- request defaultRequest { pathInfo = ["throw-custom-exception"] }
+      pure ()
+    customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f
+
+
+canTimeoutARunner :: IO ()
+canTimeoutARunner = do
+  res <- timeout 1000 $ runner $ do
+    res <- request defaultRequest { pathInfo = ["sleep-sec"] }
+    assertStatus 200 res -- if 500, it's catching the timeout exception
+    pure () -- it should've timeout by now, either being 500 or Nothing
+  res `shouldBe` Nothing -- make sure that pure statement didn't happen.

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

@@ -0,0 +1,41 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+-- | a custom app that throws an exception
+module YesodCoreTest.ErrorHandling.CustomApp
+    (CustomApp(..)
+    , MyException(..)
+
+    -- * unused
+    , Widget
+    , resourcesCustomApp
+    ) where
+
+
+import Yesod.Core.Types
+import Yesod.Core
+import qualified UnliftIO.Exception as E
+
+data CustomApp = CustomApp
+
+mkYesod "CustomApp" [parseRoutes|
+/throw-custom-exception CustomHomeR GET
+|]
+
+getCustomHomeR :: Handler Html
+getCustomHomeR =
+  E.throwIO MkMyException
+
+data MyException = MkMyException
+ deriving (Show, E.Exception)
+
+instance Yesod CustomApp where
+  -- something we couldn't do before, rethrow custom exceptions
+  catchHandlerExceptions _ action handler =
+    action `E.catch` \exception -> do
+      case E.fromException exception of
+        Just MkMyException -> E.throwIO MkMyException
+        Nothing -> handler exception

yesod-core/test/YesodCoreTest/Meta.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module YesodCoreTest.Meta
+    ( metaTest
+    ) where
+
+import Test.Hspec
+
+import Yesod.Core
+import Network.Wai
+import Network.Wai.Test
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/title TitleR GET
+/desc  DescriptionR GET
+|]
+
+instance Yesod App where
+
+getTitleR :: Handler Html
+getTitleR = defaultLayout $ do
+    setTitle "First title"
+    setTitle "Second title"
+
+getDescriptionR :: Handler Html
+getDescriptionR = defaultLayout $ do
+    setDescriptionIdemp "First description"
+    setDescriptionIdemp "Second description"
+
+metaTest :: Spec
+metaTest = describe "Setting page metadata" $ do
+    describe "Yesod.Core.Widget.setTitle" $ do
+        it "is idempotent" $ runner $ do
+            res <- request defaultRequest
+                        { pathInfo = ["title"]
+                        }
+            assertBody "<!DOCTYPE html>\n<html><head><title>Second title</title></head><body></body></html>" res
+    describe "Yesod.Core.Widget.setDescriptionIdemp" $ do
+        it "is idempotent" $ runner $ do
+            res <- request defaultRequest
+                        { pathInfo = ["desc"]
+                        }
+            assertBody "<!DOCTYPE html>\n<html><head><title></title><meta name=\"description\" content=\"Second description\"></head><body></body></html>" res
+
+runner :: Session () -> IO ()
+runner f = toWaiAppPlain App >>= runSession f

yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs

@@ -21,13 +21,13 @@ import qualified Data.ByteString.Lazy.Char8 as L8
 getSubsite :: a -> Subsite
 getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)
 
-getBarR :: Monad m => m T.Text
+getBarR :: MonadHandler m => m T.Text
 getBarR = return $ T.pack "BarR"
 
-getBazR :: (HasHandlerData env, Yesod (HandlerSite env)) => RIO env Html
+getBazR :: (MonadHandler m, Yesod (HandlerSite m)) => m Html
 getBazR = liftHandler $ defaultLayout [whamlet|Used Default Layout|]
 
-getBinR :: (HasHandlerData env, Yesod (HandlerSite env), SubHandlerSite env ~ Subsite) => RIO env Html
+getBinR :: (MonadHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html
 getBinR = do
     routeToParent <- getRouteToParent
     liftHandler $ defaultLayout [whamlet|

yesod-core/test/YesodCoreTest/ParameterizedSite.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+module YesodCoreTest.ParameterizedSite
+    ( parameterizedSiteTest
+    ) where
+
+import Data.ByteString.Lazy (ByteString)
+import Network.Wai.Test (runSession, request, defaultRequest, assertBodyContains)
+import Test.Hspec (Spec, describe, it)
+import Yesod.Core (YesodDispatch)
+import Yesod.Core.Dispatch (toWaiApp)
+
+import YesodCoreTest.ParameterizedSite.PolyAny (PolyAny (..))
+import YesodCoreTest.ParameterizedSite.PolyShow (PolyShow (..))
+import YesodCoreTest.ParameterizedSite.Compat (Compat (..))
+
+-- These are actually tests for template haskell. So if it compiles, it works
+parameterizedSiteTest :: Spec
+parameterizedSiteTest = describe "Polymorphic Yesod sites" $ do
+    it "Polymorphic unconstrained stub" $ runStub (PolyAny ())
+    it "Polymorphic stub with Show" $ runStub' "1337" (PolyShow 1337)
+    it "Polymorphic unconstrained stub, old-style" $ runStub (Compat () ())
+
+runStub :: YesodDispatch a => a -> IO ()
+runStub stub =
+    let actions = do
+            res <- request defaultRequest
+            assertBodyContains "Stub" res
+    in toWaiApp stub >>= runSession actions
+
+
+runStub' :: YesodDispatch a => ByteString -> a -> IO ()
+runStub' body stub =
+    let actions = do
+            res <- request defaultRequest
+            assertBodyContains "Stub" res
+            assertBodyContains body res
+    in toWaiApp stub >>= runSession actions

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

@@ -0,0 +1,27 @@
+{-# LANGUAGE
+    TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
+  , OverloadedStrings, StandaloneDeriving, FlexibleInstances
+  #-}
+module YesodCoreTest.ParameterizedSite.Compat
+    ( Compat (..)
+    ) where
+
+import Yesod.Core
+
+-- | Parameterized without constraints, and we call mkYesod without type vars,
+-- like people used to do before the last 3 commits
+data Compat a b = Compat a b
+
+mkYesod "Compat" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod (Compat a b)
+
+getHomeR :: Handler a b Html
+getHomeR = defaultLayout
+    [whamlet|
+        <p>
+            Stub
+    |]
+

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

@@ -0,0 +1,26 @@
+{-# LANGUAGE
+    TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
+  , OverloadedStrings, StandaloneDeriving, FlexibleInstances
+  #-}
+module YesodCoreTest.ParameterizedSite.PolyAny
+    ( PolyAny (..)
+    ) where
+
+import Yesod.Core
+
+-- | Parameterized without constraints
+data PolyAny a = PolyAny a
+
+mkYesod "PolyAny a" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod (PolyAny a)
+
+getHomeR :: Handler a Html
+getHomeR = defaultLayout
+    [whamlet|
+        <p>
+            Stub
+    |]
+

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

@@ -0,0 +1,28 @@
+{-# LANGUAGE
+    TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
+  , OverloadedStrings, StandaloneDeriving, FlexibleInstances
+  #-}
+module YesodCoreTest.ParameterizedSite.PolyShow
+    ( PolyShow (..)
+    ) where
+
+import Yesod.Core
+
+-- | Parameterized with 'Show' constraint
+data PolyShow a = PolyShow a
+
+mkYesod "(Show a) => PolyShow a" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Show a => Yesod (PolyShow a)
+
+getHomeR :: Show a => Handler a Html
+getHomeR = do
+    PolyShow x <- getYesod
+    defaultLayout
+        [whamlet|
+            <p>
+                Stub #{show x}
+        |]
+

yesod-core/test/YesodCoreTest/SubSub.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module YesodCoreTest.SubSub where
+
+import Test.Hspec
+
+import Yesod.Core
+import Network.Wai.Test
+import qualified Data.Text as T
+import qualified Data.ByteString.Lazy.Char8 as L8
+
+import YesodCoreTest.SubSubData
+
+data App = App { getOuter :: OuterSubSite }
+
+mkYesod "App" [parseRoutes|
+/ OuterSubSiteR OuterSubSite getOuter
+|]
+
+instance Yesod App
+
+getSubR :: SubHandlerFor InnerSubSite master T.Text
+getSubR = return $ T.pack "sub"
+
+instance YesodSubDispatch OuterSubSite master where
+  yesodSubDispatch = $(mkYesodSubDispatch resourcesOuterSubSite)
+
+instance YesodSubDispatch InnerSubSite master where
+  yesodSubDispatch = $(mkYesodSubDispatch resourcesInnerSubSite)
+
+app :: App
+app = App { getOuter = OuterSubSite { getInner = InnerSubSite }}
+
+runner :: Session () -> IO ()
+runner f = toWaiApp app >>= runSession f
+
+case_subSubsite :: IO ()
+case_subSubsite = runner $ do
+  res <- request defaultRequest
+  assertBody (L8.pack "sub") res
+  assertStatus 200 res
+
+subSubTest :: Spec
+subSubTest = describe "YesodCoreTest.SubSub" $ do
+  it "sub_subsite" case_subSubsite

yesod-core/test/YesodCoreTest/SubSubData.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module YesodCoreTest.SubSubData where
+
+import Yesod.Core
+
+
+data OuterSubSite = OuterSubSite { getInner :: InnerSubSite }
+
+data InnerSubSite = InnerSubSite
+
+mkYesodSubData "InnerSubSite" [parseRoutes|
+/ SubR GET
+|]
+
+mkYesodSubData "OuterSubSite" [parseRoutes|
+/ InnerSubSiteR InnerSubSite getInner
+|]

yesod-core/test/YesodCoreTest/Widget.hs

@@ -98,7 +98,7 @@ widgetTest = describe "Test.Widget" $ do
     assertBody "<!DOCTYPE html>\n<html><head><title></title><script>toHead</script><toHead></toHead>\n<style>toWidget{bar:baz}toHead{bar:baz}</style></head><body><script>toBody</script><p>toWidget</p>\n<p>toBody</p>\n<script>toWidget</script></body></html>" res
 
 runner :: Session () -> IO ()
-runner f = toWaiApp Y >>= runSession f
+runner f = toWaiAppPlain Y >>= runSession f
 
 case_addJuliusBody :: IO ()
 case_addJuliusBody = runner $ do

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.13
+version:         1.6.25.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -8,7 +8,7 @@ synopsis:        Creation of type-safe, RESTful web applications.
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-core>
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.8
+cabal-version:   >= 1.10
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 extra-source-files:
@@ -17,15 +17,17 @@ extra-source-files:
   test/YesodCoreTest/JsLoaderSites/Bottom.hs
   test/en.msg
   test/test.hs
-  test/fixtures/routes_with_line_continuations
+  test/fixtures/routes_with_line_continuations.yesodroutes
   ChangeLog.md
   README.md
 
 library
+    default-language: Haskell2010
     hs-source-dirs: src
 
-    build-depends:   base                  >= 4.11     && < 5
+    build-depends:   base                  >= 4.10     && < 5
                    , aeson                 >= 1.0
+                   , attoparsec-aeson      >= 2.1
                    , auto-update
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.7.1
@@ -38,27 +40,28 @@ library
                    , containers            >= 0.2
                    , cookie                >= 0.4.3    && < 0.5
                    , deepseq               >= 1.3
+                   , entropy
                    , fast-logger           >= 2.2
                    , http-types            >= 0.7
                    , memory
+                   , monad-logger          >= 0.3.10   && < 0.4
                    , mtl
                    , parsec                >= 2        && < 3.2
                    , path-pieces           >= 0.1.2    && < 0.3
-                   , random                >= 1.0.0.2  && < 1.2
+                   , primitive             >= 0.6
+                   , random                >= 1.0.0.2  && < 1.3
                    , resourcet             >= 1.2
-                   , rio                   >= 0.1.9
-                   , rio-orphans
                    , 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.13
+                   , vector                >= 0.9      && < 0.14
                    , wai                   >= 3.2
                    , wai-extra             >= 3.0.7
-                   -- FIXME remove?
                    , wai-logger            >= 0.2
                    , warp                  >= 3.0.2
                    , word8
@@ -75,6 +78,7 @@ library
                      Yesod.Routes.TH.Types
     other-modules:   Yesod.Core.Internal.Session
                      Yesod.Core.Internal.Request
+                     Yesod.Core.Class.Handler
                      Yesod.Core.Internal.Util
                      Yesod.Core.Internal.Response
                      Yesod.Core.Internal.Run
@@ -96,14 +100,12 @@ library
                      Yesod.Routes.TH.RouteAttrs
 
     ghc-options:     -Wall
-    -- Following line added due to: https://github.com/yesodweb/yesod/issues/545
-    -- This looks like a GHC bug
-    extensions:      MultiParamTypeClasses
 
     -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
-    extensions:      TemplateHaskell
+    other-extensions:      TemplateHaskell
 
 test-suite test-routes
+    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: RouteSpec.hs
     hs-source-dirs: test, src
@@ -120,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
@@ -133,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
@@ -144,6 +147,7 @@ test-suite tests
                    YesodCoreTest.Header
                    YesodCoreTest.Csrf
                    YesodCoreTest.ErrorHandling
+                   YesodCoreTest.ErrorHandling.CustomApp
                    YesodCoreTest.Exceptions
                    YesodCoreTest.InternalRequest
                    YesodCoreTest.JsLoader
@@ -153,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
@@ -165,6 +174,8 @@ test-suite tests
                    YesodCoreTest.StubSslOnly
                    YesodCoreTest.StubStrictSameSite
                    YesodCoreTest.StubUnsecured
+                   YesodCoreTest.SubSub
+                   YesodCoreTest.SubSubData
                    YesodCoreTest.WaiSubsite
                    YesodCoreTest.Widget
                    YesodCoreTest.YesodTest
@@ -196,9 +207,10 @@ test-suite tests
                   , warp
                   , yesod-core
     ghc-options:     -Wall -threaded
-    extensions: TemplateHaskell
+    other-extensions: TemplateHaskell
 
 benchmark widgets
+    default-language: Haskell2010
     type: exitcode-stdio-1.0
     hs-source-dirs: bench
     build-depends:  base

yesod-eventsource/ChangeLog.md

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

yesod-eventsource/Yesod/EventSource.hs

@@ -22,7 +22,7 @@ import qualified Network.Wai.EventSource.EventStream as ES
 
 -- | (Internal) Find out the request's 'EventSourcePolyfill' and
 -- set any necessary headers.
-prepareForEventSource :: HasHandlerData env => RIO env EventSourcePolyfill
+prepareForEventSource :: MonadHandler m => m EventSourcePolyfill
 prepareForEventSource = do
   reqWith <- lookup "X-Requested-With" . W.requestHeaders Data.Functor.<$> waiRequest
   let polyfill | reqWith == Just "XMLHttpRequest" = Remy'sESPolyfill
@@ -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,14 +8,14 @@ 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
+    build-depends:   base                  >= 4.10     && < 5
                    , blaze-builder
                    , conduit               >= 1.3
                    , transformers

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,5 +1,45 @@
 # 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

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,6 +32,7 @@ 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 Yesod.Form.Types
 import Yesod.Form.Functions
@@ -140,7 +141,7 @@ data BootstrapFormLayout =
 -- | Render the given form using Bootstrap v3 conventions.
 --
 -- Since: yesod-form 1.3.8
-renderBootstrap3 :: BootstrapFormLayout -> FormRender site a
+renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
 renderBootstrap3 formLayout aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
@@ -154,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
@@ -164,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}
@@ -223,8 +224,8 @@ instance IsString msg => IsString (BootstrapSubmit msg) where
 --
 -- Since: yesod-form 1.3.8
 bootstrapSubmit
-    :: RenderMessage site msg
-    => BootstrapSubmit msg -> AForm site ()
+    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    => BootstrapSubmit msg -> AForm m ()
 bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
 
 
@@ -234,8 +235,8 @@ bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
 --
 -- Since: yesod-form 1.3.8
 mbootstrapSubmit
-    :: RenderMessage site msg
-    => BootstrapSubmit msg -> MForm site (FormResult (), FieldView site)
+    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    => BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
 mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
     let res = FormSuccess ()
         widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]

yesod-form/Yesod/Form/Fields.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# 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.
@@ -46,8 +46,10 @@ module Yesod.Form.Fields
     , selectFieldHelper
     , selectField
     , selectFieldList
+    , selectFieldListGrouped
     , radioField
     , radioFieldList
+    , withRadioField
     , checkboxesField
     , checkboxesFieldList
     , multiSelectField
@@ -55,23 +57,25 @@ module Yesod.Form.Fields
     , Option (..)
     , OptionList (..)
     , mkOptionList
+    , mkOptionListGrouped
     , optionsPersist
     , optionsPersistKey
     , optionsPairs
+    , optionsPairsGrouped
     , optionsEnum
+    , colorField
+    , datetimeLocalField
     ) where
 
-import RIO
 import Yesod.Form.Types
 import Yesod.Form.I18n.English
 import Yesod.Form.Functions (parseHelper)
 import Yesod.Core
 import Text.Blaze (ToMarkup (toMarkup), unsafeByteString)
-import Prelude (zipWith)
 #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)
@@ -83,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)
 
@@ -95,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
@@ -116,14 +121,16 @@ import Data.String (IsString)
 import Data.Monoid
 #endif
 
+import Data.Char (isHexDigit)
+
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
 
 -- | Creates a input with @type="number"@ and @step=1@.
-intField :: (Integral i, RenderMessage site FormMessage) => Field site i
+intField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Field m i
 intField = Field
     { fieldParse = parseHelper $ \s ->
-        case Data.Text.Read.signed Data.Text.Read.decimal s of -- FIXME it overflows
+        case Data.Text.Read.signed Data.Text.Read.decimal s of
             Right (a, "") -> Right a
             _ -> Left $ MsgInvalidInteger s
 
@@ -138,7 +145,7 @@ $newline never
     showI x = show (fromIntegral x :: Integer)
 
 -- | Creates a input with @type="number"@ and @step=any@.
-doubleField :: RenderMessage site FormMessage => Field site Double
+doubleField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Double
 doubleField = Field
     { fieldParse = parseHelper $ \s ->
         case Data.Text.Read.double (prependZero s) of
@@ -156,7 +163,7 @@ $newline never
 -- | Creates an input with @type="date"@, validating the input using the 'parseDate' function.
 --
 -- Add the @time@ package and import the "Data.Time.Calendar" module to use this function.
-dayField :: RenderMessage site FormMessage => Field site Day
+dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day
 dayField = Field
     { fieldParse = parseHelper $ parseDate . unpack
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -168,28 +175,28 @@ $newline never
   where showVal = either id (pack . show)
 
 -- | An alias for 'timeFieldTypeTime'.
-timeField :: RenderMessage site FormMessage => Field site TimeOfDay
+timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
 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
-timeFieldTypeTime :: RenderMessage site FormMessage => Field site TimeOfDay  
+-- @since 1.4.2
+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
-timeFieldTypeText :: RenderMessage site FormMessage => Field site TimeOfDay
+-- @since 1.4.2
+timeFieldTypeText :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
 timeFieldTypeText = timeFieldOfType "text"
 
-timeFieldOfType :: RenderMessage site FormMessage => Text -> Field site TimeOfDay
+timeFieldOfType :: Monad m => RenderMessage (HandlerSite m) FormMessage => Text -> Field m TimeOfDay
 timeFieldOfType inputType = Field
     { fieldParse = parseHelper parseTime
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -206,7 +213,7 @@ $newline never
         fullSec = fromInteger $ floor $ todSec tod
 
 -- | Creates a @\<textarea>@ tag whose input is sanitized to prevent XSS attacks and is validated for having balanced tags.
-htmlField :: RenderMessage site FormMessage => Field site Html
+htmlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html
 htmlField = Field
     { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -218,7 +225,7 @@ $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.
@@ -242,7 +249,7 @@ instance ToHtml Textarea where
         writeHtmlEscapedChar c    = B.writeHtmlEscapedChar c
 
 -- | Creates a @\<textarea>@ tag whose returned value is wrapped in a 'Textarea'; see 'Textarea' for details.
-textareaField :: RenderMessage site FormMessage => Field site Textarea
+textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea
 textareaField = Field
     { fieldParse = parseHelper $ Right . Textarea
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -253,8 +260,8 @@ $newline never
     }
 
 -- | Creates an input with @type="hidden"@; you can use this to store information in a form that users shouldn't see (for example, Yesod stores CSRF tokens in a hidden field).
-hiddenField :: (PathPiece p, RenderMessage site FormMessage)
-            => Field site p
+hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage)
+            => Field m p
 hiddenField = Field
     { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece
     , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
@@ -265,7 +272,7 @@ $newline never
     }
 
 -- | Creates a input with @type="text"@.
-textField :: RenderMessage site FormMessage => Field site Text
+textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
 textField = Field
     { fieldParse = parseHelper $ Right
     , fieldView = \theId name attrs val isReq ->
@@ -276,7 +283,7 @@ $newline never
     , fieldEnctype = UrlEncoded
     }
 -- | Creates an input with @type="password"@.
-passwordField :: RenderMessage site FormMessage => Field site Text
+passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
 passwordField = Field
     { fieldParse = parseHelper $ Right
     , fieldView = \theId name attrs _ isReq -> toWidget [hamlet|
@@ -286,10 +293,15 @@ $newline never
     , fieldEnctype = UrlEncoded
     }
 
+readMay :: Read a => String -> Maybe a
+readMay s = case filter (Prelude.null . snd) $ reads s of
+                (x, _):_ -> Just x
+                [] -> Nothing
+
 -- | Parses a 'Day' from a 'String'.
 parseDate :: String -> Either FormMessage Day
 parseDate = maybe (Left MsgInvalidDay) Right
-              . readMaybe . replace '/' '-'
+              . readMay . replace '/' '-'
 
 -- | Replaces all instances of a value in a list by another value.
 -- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace
@@ -297,7 +309,7 @@ replace :: Eq a => a -> a -> [a] -> [a]
 replace x y = map (\z -> if z == x then y else z)
 
 parseTime :: Text -> Either FormMessage TimeOfDay
-parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMaybe . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser
+parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser
 
 timeParser :: Parser TimeOfDay
 timeParser = do
@@ -329,10 +341,7 @@ timeParser = do
         x <- digit
         y <- (return Control.Applicative.<$> digit) <|> return []
         let xy = x : y
-        let i =
-              case readMaybe xy of
-                Just i' -> i'
-                Nothing -> error $ "The impossible happened parsing: " ++ show xy
+        let i = read xy
         if i < 0 || i >= 24
             then fail $ show $ MsgInvalidHour $ pack xy
             else return i
@@ -341,16 +350,13 @@ timeParser = do
         x <- digit
         y <- digit <|> fail (show $ msg $ pack [x])
         let xy = [x, y]
-        let i =
-              case readMaybe xy of
-                Just i' -> i'
-                Nothing -> error $ "The impossible happened parsing: " ++ show xy
+        let i = read xy
         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 :: RenderMessage site FormMessage => Field site Text
+emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
 emailField = Field
     { fieldParse = parseHelper $
         \s ->
@@ -366,8 +372,8 @@ $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
-multiEmailField :: RenderMessage site FormMessage => Field site [Text]
+-- @since 1.3.7
+multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
 multiEmailField = Field
     { fieldParse = parseHelper $
         \s ->
@@ -391,7 +397,7 @@ $newline never
 
 type AutoFocus = Bool
 -- | Creates an input with @type="search"@. For <http://caniuse.com/#search=autofocus browsers without autofocus support>, a JS fallback is used if @AutoFocus@ is true.
-searchField :: RenderMessage site FormMessage => AutoFocus -> Field site Text
+searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text
 searchField autoFocus = Field
     { fieldParse = parseHelper Right
     , fieldView = \theId name attrs val isReq -> do
@@ -412,7 +418,7 @@ $newline never
     , fieldEnctype = UrlEncoded
     }
 -- | Creates an input with @type="url"@, validating the URL according to RFC3986.
-urlField :: RenderMessage site FormMessage => Field site Text
+urlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
 urlField = Field
     { fieldParse = parseHelper $ \s ->
         case parseURI $ unpack s of
@@ -428,15 +434,23 @@ urlField = Field
 -- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing
 selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
                 => [(msg, a)]
-                -> Field site a
+                -> 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)
             => HandlerFor site (OptionList a)
-            -> Field site a
+            -> Field (HandlerFor site) a
 selectField = selectFieldHelper
     (\theId name attrs inside -> [whamlet|
 $newline never
@@ -450,19 +464,22 @@ $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)
                      => [(msg, a)]
-                     -> Field site [a]
+                     -> Field (HandlerFor site) [a]
 multiSelectFieldList = multiSelectField . optionsPairs
 
 -- | Creates a @\<select>@ tag for selecting multiple options.
 multiSelectField :: Eq a
                  => HandlerFor site (OptionList a)
-                 -> Field site [a]
+                 -> Field (HandlerFor site) [a]
 multiSelectField ioptlist =
-    Field parse view' UrlEncoded
+    Field parse view UrlEncoded
   where
     parse [] _ = return $ Right Nothing
     parse optlist _ = do
@@ -471,7 +488,7 @@ multiSelectField ioptlist =
              Nothing -> return $ Left "Error parsing values"
              Just res -> return $ Right $ Just res
 
-    view' theId name attrs val isReq = do
+    view theId name attrs val isReq = do
         opts <- fmap olOptions $ handlerToWidget ioptlist
         let selOpts = map (id &&& (optselected val)) opts
         [whamlet|
@@ -486,18 +503,18 @@ multiSelectField ioptlist =
 -- | Creates an input with @type="radio"@ for selecting one option.
 radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
                => [(msg, a)]
-               -> Field site a
+               -> Field (HandlerFor site) a
 radioFieldList = radioField . optionsPairs
 
 -- | Creates an input with @type="checkbox"@ for selecting multiple options.
 checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)]
-                     -> Field site [a]
+                     -> Field (HandlerFor site) [a]
 checkboxesFieldList = checkboxesField . optionsPairs
 
 -- | Creates an input with @type="checkbox"@ for selecting multiple options.
 checkboxesField :: Eq a
                  => HandlerFor site (OptionList a)
-                 -> Field site [a]
+                 -> Field (HandlerFor site) [a]
 checkboxesField ioptlist = (multiSelectField ioptlist)
     { fieldView =
         \theId name attrs val _isReq -> do
@@ -515,35 +532,62 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
 -- | Creates an input with @type="radio"@ for selecting one option.
 radioField :: (Eq a, RenderMessage site FormMessage)
            => HandlerFor site (OptionList a)
-           -> Field site a
-radioField = selectFieldHelper
-    (\theId _name _attrs inside -> [whamlet|
+           -> Field (HandlerFor site) a
+radioField = withRadioField
+    (\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>
-        <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
-        _{MsgSelectNone}
+<div .radio>
+    <label for=#{theId}-#{value}>
+        <div>
+            ^{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>
-        <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
-        \#{text}
-|])
+<div ##{theId}>^{inside'}
+|]
+    onOpt theId name isSel = nothingFun theId $ [whamlet|
+$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 :: RenderMessage site FormMessage => Field site Bool
+boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
 boolField = Field
       { fieldParse = \e _ -> return $ boolParser e
       , fieldView = \theId name attrs val isReq -> [whamlet|
@@ -574,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
@@ -582,7 +626,7 @@ $newline never
 --
 --   Note that this makes the field always optional.
 --
-checkBoxField :: Field site Bool
+checkBoxField :: Monad m => Field m Bool
 checkBoxField = Field
     { fieldParse = \e _ -> return $ checkBoxParser e
     , fieldView  = \theId name attrs val _ -> [whamlet|
@@ -602,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
@@ -619,29 +679,63 @@ 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
+    fmap f (Option display internal external) = Option display (f internal) external
 
 -- | Creates an 'OptionList' from a list of (display-value, internal value) pairs.
-optionsPairs :: RenderMessage site msg => [(msg, a)] -> HandlerFor site (OptionList a)
+optionsPairs :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
+             => [(msg, a)] -> m (OptionList a)
 optionsPairs opts = do
   mr <- getMessageRender
-  let mkOption external (display', internal) =
-          Option { optionDisplay       = mr display'
+  let mkOption external (display, internal) =
+          Option { optionDisplay       = mr display
                  , optionInternalValue = internal
                  , optionExternalValue = pack $ show external
                  }
   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 :: (Show a, Enum a, Bounded a) => HandlerFor site (OptionList a)
+optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
 optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
 
 -- | Selects a list of 'Entity's with the given 'Filter' and 'SelectOpt's. The @(a -> msg)@ function is then used to derive the display value for an 'OptionList'. Example usage:
@@ -659,22 +753,33 @@ optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
 -- >         <$> areq (selectField countries) "Which country do you live in?" Nothing
 -- >         where
 -- >           countries = optionsPersist [] [Asc CountryName] countryName
+#if MIN_VERSION_persistent(2,5,0)
 optionsPersist :: ( YesodPersist site
                   , PersistQueryRead backend
                   , PathPiece (Key a)
                   , RenderMessage site msg
                   , YesodPersistBackend site ~ backend
                   , PersistRecordBackend a backend
-                  , site ~ HandlerSite env
-                  , HasHandlerData env
                   )
                => [Filter a]
                -> [SelectOpt a]
                -> (a -> msg)
-               -> RIO env (OptionList (Entity a))
+               -> HandlerFor site (OptionList (Entity a))
+#else
+optionsPersist :: ( YesodPersist site, PersistEntity a
+                  , PersistQuery (PersistEntityBackend a)
+                  , PathPiece (Key a)
+                  , RenderMessage site msg
+                  , YesodPersistBackend site ~ PersistEntityBackend a
+                  )
+               => [Filter a]
+               -> [SelectOpt a]
+               -> (a -> msg)
+               -> HandlerFor site (OptionList (Entity a))
+#endif
 optionsPersist filts ords toDisplay = fmap mkOptionList $ do
     mr <- getMessageRender
-    pairs <- liftHandler $ runDB $ selectList filts ords
+    pairs <- runDB $ selectList filts ords
     return $ map (\(Entity key value) -> Option
         { optionDisplay = mr (toDisplay value)
         , optionInternalValue = Entity key value
@@ -684,22 +789,36 @@ 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
+  :: (YesodPersist site
      , PersistQueryRead backend
      , PathPiece (Key a)
      , RenderMessage site msg
      , backend ~ YesodPersistBackend site
-     , site ~ HandlerSite env
      , PersistRecordBackend a backend
-     , HasHandlerData env
      )
   => [Filter a]
   -> [SelectOpt a]
   -> (a -> msg)
-  -> RIO env (OptionList (Key a))
-optionsPersistKey filts ords toDisplay = liftHandler $ fmap mkOptionList $ do
+  -> HandlerFor site (OptionList (Key a))
+#else
+optionsPersistKey
+  :: (YesodPersist site
+     , PersistEntity a
+     , PersistQuery (PersistEntityBackend a)
+     , PathPiece (Key a)
+     , RenderMessage site msg
+     , YesodPersistBackend site ~ PersistEntityBackend a
+     )
+  => [Filter a]
+  -> [SelectOpt a]
+  -> (a -> msg)
+  -> HandlerFor site (OptionList (Key a))
+#endif
+
+optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
     mr <- getMessageRender
     pairs <- runDB $ selectList filts ords
     return $ map (\(Entity key value) -> Option
@@ -709,7 +828,7 @@ optionsPersistKey filts ords toDisplay = liftHandler $ fmap mkOptionList $ do
         }) pairs
 
 -- |
--- A helper function for constucting 'selectField's. You may want to use this when you define your custom 'selectField's or 'radioField's.
+-- A helper function for constucting 'selectField's with optional option groups. You may want to use this when you define your custom 'selectField's or 'radioField's.
 --
 -- @since 1.6.2
 selectFieldHelper
@@ -717,23 +836,26 @@ selectFieldHelper
         => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()) -- ^ Outermost part of the field
         -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional
         -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options
+        -> (Maybe (Text -> WidgetFor site ())) -- ^ Group headers placed inbetween options
         -> HandlerFor site (OptionList a)
-        -> Field site a
-selectFieldHelper outside onOpt inside opts' = Field
+        -> Field (HandlerFor site) a
+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
-            flip mapM_ opts $ \opt -> inside
-                theId
-                name
-                ((if isReq then (("required", "required"):) else id) attrs)
-                (optionExternalValue opt)
-                ((render opts val) == optionExternalValue opt)
-                (optionDisplay opt)
+          optsFlat <- fmap (olOptions.flattenOptionList) $ handlerToWidget opts'
+          unless isReq $ onOpt theId name $ render optsFlat val `notElem` map optionExternalValue optsFlat
+          opts'' <- handlerToWidget opts'
+          case opts'' of
+            OptionList{} -> constructOptions theId name attrs val isReq optsFlat
+            OptionListGrouped{olOptionsGrouped=grps} -> do
+                  forM_ grps $ \(grp, opts) -> do
+                    case grpHdr of
+                      Just hdr -> hdr grp
+                      Nothing -> return ()
+                    constructOptions theId name attrs val isReq opts
     , fieldEnctype = UrlEncoded
     }
   where
@@ -746,9 +868,18 @@ 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 :: Field site FileInfo
+fileField :: Monad m
+          => Field m FileInfo
 fileField = Field
     { fieldParse = \_ files -> return $
         case files of
@@ -760,23 +891,18 @@ fileField = Field
     , fieldEnctype = Multipart
     }
 
-fileAFormReq :: RenderMessage site FormMessage
-             => FieldSettings site -> AForm site FileInfo
-fileAFormReq fs = AForm $ do
-    site <- getYesod
-    langs <- reqLangs <$> getRequest
-    WFormData viewsDeque mfd <- view id
-    ints <- readIORef $ mfdInts mfd
+fileAFormReq :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
+             => FieldSettings (HandlerSite m) -> AForm m FileInfo
+fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do
     let (name, ints') =
             case fsName fs of
                 Just x -> (x, ints)
                 Nothing ->
                     let i' = incrInts ints
                      in (pack $ 'f' : show i', i')
-    writeIORef (mfdInts mfd) ints'
     id' <- maybe newIdent return $ fsId fs
     let (res, errs) =
-            case mfdParams mfd of
+            case menvs of
                 Nothing -> (FormMissing, Nothing)
                 Just (_, fenv) ->
                     case Map.lookup name fenv of
@@ -795,26 +921,21 @@ $newline never
             , fvErrors = errs
             , fvRequired = True
             }
-    writeIORef (mfdEnctype mfd) Multipart
-    pushBackDeque viewsDeque fv
-    return res
+    return (res, (fv :), ints', Multipart)
 
-fileAFormOpt :: FieldSettings site -> AForm site (Maybe FileInfo)
-fileAFormOpt fs = AForm $ do
-    master <- getYesod
-    langs <- reqLangs <$> getRequest
-    WFormData viewsDeque mfd <- view id
-    ints <- readIORef $ mfdInts mfd
+fileAFormOpt :: MonadHandler m
+             => FieldSettings (HandlerSite m)
+             -> AForm m (Maybe FileInfo)
+fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
     let (name, ints') =
             case fsName fs of
                 Just x -> (x, ints)
                 Nothing ->
                     let i' = incrInts ints
                      in (pack $ 'f' : show i', i')
-    writeIORef (mfdInts mfd) ints'
     id' <- maybe newIdent return $ fsId fs
     let (res, errs) =
-            case mfdParams mfd of
+            case menvs of
                 Nothing -> (FormMissing, Nothing)
                 Just (_, fenv) ->
                     case Map.lookup name fenv of
@@ -831,9 +952,7 @@ $newline never
             , fvErrors = errs
             , fvRequired = False
             }
-    writeIORef (mfdEnctype mfd) Multipart
-    pushBackDeque viewsDeque fv
-    return res
+    return (res, (fv :), ints', Multipart)
 
 incrInts :: Ints -> Ints
 incrInts (IntSingle i) = IntSingle $ i + 1
@@ -853,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

@@ -1,4 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -19,10 +18,13 @@ module Yesod.Form.Functions
     , wFormToMForm
       -- * Fields to Forms
     , wreq
+    , wreqMsg
     , wopt
     , mreq
+    , mreqMsg
     , mopt
     , areq
+    , areqMsg
     , aopt
       -- * Run a form
     , runFormPost
@@ -39,6 +41,7 @@ module Yesod.Form.Functions
     , renderTable
     , renderDivs
     , renderDivsNoLabels
+    , renderBootstrap
     , renderBootstrap2
       -- * Validation
     , check
@@ -55,12 +58,13 @@ module Yesod.Form.Functions
     , removeClass
     ) where
 
-import RIO hiding (ask, local)
 import Yesod.Form.Types
-import Yesod.Core.Types (liftHandler)
 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)
+import Control.Monad.Trans.Writer (runWriterT, writer)
 import Control.Monad (liftM, join)
 import Data.Byteable (constEqBytes)
 import Text.Blaze (Markup, toMarkup)
@@ -74,28 +78,8 @@ import qualified Data.Map as Map
 import qualified Data.Text.Encoding as TE
 import Control.Arrow (first)
 
-get :: MForm site Ints
-get = view (to mfdInts) >>= readIORef
-
-put :: Ints -> MForm site ()
-put ints = view (to mfdInts) >>= (`writeIORef` ints)
-
-tell :: Enctype -> MForm site ()
-tell ec = view (to mfdEnctype) >>= (`writeIORef` ec)
-
-local
-  :: ( Maybe (Env, FileEnv)
-    -> Maybe (Env, FileEnv)
-     )
-  -> MForm site a
-  -> MForm site a
-local f inner = do
-  mfd <- view id
-  let mfd' = mfd { mfdParams = f $ mfdParams mfd }
-  runRIO mfd' inner
-
 -- | Get a unique identifier.
-newFormIdent :: MForm site Text
+newFormIdent :: Monad m => MForm m Text
 newFormIdent = do
     i <- get
     let i' = incrInts i
@@ -105,35 +89,60 @@ newFormIdent = do
     incrInts (IntSingle i) = IntSingle $ i + 1
     incrInts (IntCons i is) = (i + 1) `IntCons` is
 
-formToAForm :: MForm site (FormResult a, [FieldView site]) -> AForm site a
-formToAForm mform = AForm $ do
-  WFormData viewsDeque mfd <- view id
-  (a, views) <- runRIO mfd mform
-  for_ views $ pushBackDeque viewsDeque
-  pure a
+formToAForm :: (HandlerSite m ~ site, Monad m)
+            => MForm m (FormResult a, [FieldView site])
+            -> AForm m a
+formToAForm form = AForm $ \(site, langs) env ints -> do
+    ((a, xmls), ints', enc) <- runRWST form (env, site, langs) ints
+    return (a, (++) xmls, ints', enc)
 
-aFormToForm :: AForm site a
-            -> MForm site (FormResult a, [FieldView site] -> [FieldView site])
-aFormToForm (AForm wform) = do
-    (res, views) <- wFormToMForm wform
-    pure (res, (views++))
+aFormToForm :: (Monad m, HandlerSite m ~ site)
+            => AForm m a
+            -> MForm m (FormResult a, [FieldView site] -> [FieldView site])
+aFormToForm (AForm aform) = do
+    ints <- get
+    (env, site, langs) <- ask
+    (a, xml, ints', enc) <- lift $ aform (site, langs) env ints
+    put ints'
+    tell enc
+    return (a, xml)
 
-askParams :: MForm site (Maybe Env)
-askParams = view $ to (fmap fst . mfdParams)
+askParams :: Monad m => MForm m (Maybe Env)
+askParams = do
+    (x, _, _) <- ask
+    return $ liftM fst x
 
-askFiles :: MForm site (Maybe FileEnv)
-askFiles = view $ to (fmap snd . mfdParams)
+askFiles :: Monad m => MForm m (Maybe FileEnv)
+askFiles = do
+    (x, _, _) <- ask
+    return $ liftM snd x
 
 -- | Converts a form field into monadic form 'WForm'. This field requires a
 -- value and will return 'FormFailure' if left empty.
 --
 -- @since 1.4.14
-wreq :: RenderMessage site FormMessage
-     => Field site a        -- ^ form field
+wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+     => Field m a           -- ^ form field
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe a             -- ^ optional default value
-     -> WForm site (FormResult a)
-wreq f fs = mFormToWForm . mreq f fs
+     -> WForm m (FormResult a)
+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
@@ -141,78 +150,92 @@ wreq f fs = mFormToWForm . mreq f fs
 -- value).
 --
 -- @since 1.4.14
-wopt :: Field site a        -- ^ form field
+wopt :: (MonadHandler m, HandlerSite m ~ site)
+     => Field m a           -- ^ form field
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe (Maybe a)     -- ^ optional default value
-     -> WForm site (FormResult (Maybe a))
+     -> WForm m (FormResult (Maybe a))
 wopt f fs = mFormToWForm . mopt f fs
 
 -- | Converts a monadic form 'WForm' into an applicative form 'AForm'.
 --
 -- @since 1.4.14
-wFormToAForm
-  :: WForm site (FormResult a)  -- ^ input form
-  -> AForm site a               -- ^ output form
+wFormToAForm :: MonadHandler m
+             => WForm m (FormResult a)  -- ^ input form
+             -> AForm m a               -- ^ output form
 wFormToAForm = formToAForm . wFormToMForm
 
 -- | Converts a monadic form 'WForm' into another monadic form 'MForm'.
 --
 -- @since 1.4.14
-wFormToMForm
-  :: WForm site a                      -- ^ input form
-  -> MForm site (a, [FieldView site])  -- ^ output form
-wFormToMForm wform = do
-  viewsDeque <- newDeque
-  mfd <- view id
-  a <- runRIO (WFormData viewsDeque mfd) wform
-  views <- dequeToList viewsDeque
-  pure (a, views)
+wFormToMForm :: (MonadHandler m, HandlerSite m ~ site)
+             => WForm m a                      -- ^ input form
+             -> MForm m (a, [FieldView site])  -- ^ output form
+wFormToMForm = mapRWST (fmap group . runWriterT)
+  where
+    group ((a, ints, enctype), views) = ((a, views), ints, enctype)
 
 -- | Converts a monadic form 'MForm' into another monadic form 'WForm'.
 --
 -- @since 1.4.14
-mFormToWForm
-  :: MForm site (a, FieldView site)  -- ^ input form
-  -> WForm site a                    -- ^ output form
-mFormToWForm mform = do
-  WFormData viewsDeque mfd <- view id
-  (a, view') <- runRIO mfd mform
-  pushBackDeque viewsDeque view'
-  pure a
+mFormToWForm :: (MonadHandler m, HandlerSite m ~ site)
+             => MForm m (a, FieldView site)  -- ^ input form
+             -> WForm m a                    -- ^ output form
+mFormToWForm = mapRWST $ \f -> do
+  ((a, view), ints, enctype) <- lift f
+  writer ((a, ints, enctype), [view])
 
 -- | Converts a form field into monadic form. This field requires a value
 -- and will return 'FormFailure' if left empty.
-mreq :: RenderMessage site FormMessage
-     => Field site a         -- ^ form field
+mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+     => Field m a           -- ^ form field
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe a             -- ^ optional default value
-     -> MForm site (FormResult a, FieldView site)
-mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
+     -> MForm m (FormResult a, FieldView site)
+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'.
 -- Arguments are the same as for 'mreq' (apart from type of default value).
-mopt :: Field site a
+mopt :: (site ~ HandlerSite m, MonadHandler m)
+     => Field m a
      -> FieldSettings site
      -> Maybe (Maybe a)
-     -> MForm site (FormResult (Maybe a), FieldView site)
+     -> MForm m (FormResult (Maybe a), FieldView site)
 mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
 
-mhelper :: Field site a
+mhelper :: (site ~ HandlerSite m, MonadHandler m)
+        => Field m a
         -> FieldSettings site
         -> Maybe a
         -> (site -> [Text] -> FormResult b) -- ^ on missing
         -> (a -> FormResult b) -- ^ on success
         -> Bool -- ^ is it required?
-        -> MForm site (FormResult b, FieldView site)
+        -> MForm m (FormResult b, FieldView site)
 
 mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
     tell fieldEnctype
     mp <- askParams
     name <- maybe newFormIdent return fsName
-    theId <- maybe newIdent return fsId
-    site <- getYesod
-    langs <- reqLangs <$> getRequest
+    theId <- lift $ maybe newIdent return fsId
+    (_, site, langs) <- ask
     let mr2 = renderMessage site langs
     (res, val) <-
         case mp of
@@ -221,7 +244,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
                 mfs <- askFiles
                 let mvals = fromMaybe [] $ Map.lookup name p
                     files = fromMaybe [] $ mfs >>= Map.lookup name
-                emx <- liftHandler $ fieldParse mvals files
+                emx <- lift $ fieldParse mvals files
                 return $ case emx of
                     Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals))
                     Right mx ->
@@ -241,37 +264,44 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
         })
 
 -- | Applicative equivalent of 'mreq'.
-areq :: RenderMessage site FormMessage
-     => Field site a
-     -> FieldSettings site
-     -> Maybe a
-     -> AForm site a
-areq a b = formToAForm . liftM (second return) . mreq a b
+areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+     => Field m a           -- ^ form field
+     -> FieldSettings site  -- ^ settings for this field
+     -> Maybe a             -- ^ optional default value
+     -> AForm m a
+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 :: Field site a
-     -> FieldSettings site
+aopt :: MonadHandler m
+     => Field m a
+     -> FieldSettings (HandlerSite m)
      -> Maybe (Maybe a)
-     -> AForm site (Maybe a)
+     -> AForm m (Maybe a)
 aopt a b = formToAForm . liftM (second return) . mopt a b
 
-runFormGeneric
-  :: HasHandlerData env
-  => MForm (HandlerSite env) a
-  -> Maybe (Env, FileEnv)
-  -> RIO env (a, Enctype)
-runFormGeneric mform params = do
-  hd <- liftHandler $ view subHandlerDataL
-  enctypeRef <- newIORef mempty
-  intsRef <- newIORef $! IntSingle 0
-  let mfd = MFormData
-        { mfdHandlerData = hd
-        , mfdEnctype = enctypeRef
-        , mfdParams = params
-        , mfdInts = intsRef
-        }
-  a <- runRIO mfd mform
-  (,) a <$> readIORef enctypeRef
+runFormGeneric :: Monad m
+               => MForm m a
+               -> HandlerSite m
+               -> [Text]
+               -> Maybe (Env, FileEnv)
+               -> m (a, Enctype)
+runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 0)
 
 -- | This function is used to both initially render a form and to later extract
 -- results from it. Note that, due to CSRF protection and a few other issues,
@@ -282,19 +312,17 @@ runFormGeneric mform params = do
 -- For example, a common case is displaying a form on a GET request and having
 -- the form submit to a POST page. In such a case, both the GET and POST
 -- handlers should use 'runFormPost'.
-runFormPost
-  :: (RenderMessage (HandlerSite env) FormMessage, HasHandlerData env)
-  => (Html -> MForm (HandlerSite env) (FormResult a, xml))
-  -> RIO env ((FormResult a, xml), Enctype)
+runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m)
+            => (Html -> MForm m (FormResult a, xml))
+            -> m ((FormResult a, xml), Enctype)
 runFormPost form = do
     env <- postEnv
     postHelper form env
 
-postHelper
-  :: (HasHandlerData env, RenderMessage (HandlerSite env) FormMessage)
-  => (Html -> MForm (HandlerSite env) (FormResult a, xml))
-  -> Maybe (Env, FileEnv)
-  -> RIO env ((FormResult a, xml), Enctype)
+postHelper  :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
+            => (Html -> MForm m (FormResult a, xml))
+            -> Maybe (Env, FileEnv)
+            -> m ((FormResult a, xml), Enctype)
 postHelper form env = do
     req <- getRequest
     let tokenKey = defaultCsrfParamName
@@ -302,14 +330,15 @@ postHelper form env = do
             case reqToken req of
                 Nothing -> Data.Monoid.mempty
                 Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|]
-    ((res, xml), enctype) <- runFormGeneric (form token) env
-    site <- getYesod
+    m <- getYesod
+    langs <- languages
+    ((res, xml), enctype) <- runFormGeneric (form token) m langs env
     let res' =
             case (res, env) of
                 (_, Nothing) -> FormMissing
                 (FormSuccess{}, Just (params, _))
                     | not (Map.lookup tokenKey params === reqToken req) ->
-                        FormFailure [renderMessage site (reqLangs req) MsgCsrfWarning]
+                        FormFailure [renderMessage m langs MsgCsrfWarning]
                 _ -> res
             -- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.
             where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constEqBytes` TE.encodeUtf8 t2
@@ -322,12 +351,12 @@ postHelper form env = do
 -- page will both receive and incoming form and produce a new, blank form. For
 -- general usage, you can stick with @runFormPost@.
 generateFormPost
-    :: (RenderMessage (HandlerSite env) FormMessage, HasHandlerData env)
-    => (Html -> MForm (HandlerSite env) (FormResult a, xml))
-    -> RIO env (xml, Enctype)
+    :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)
+    => (Html -> MForm m (FormResult a, xml))
+    -> m (xml, Enctype)
 generateFormPost form = first snd `liftM` postHelper form Nothing
 
-postEnv :: HasHandlerData env => RIO env (Maybe (Env, FileEnv))
+postEnv :: MonadHandler m => m (Maybe (Env, FileEnv))
 postEnv = do
     req <- getRequest
     if requestMethod (reqWaiRequest req) == "GET"
@@ -337,16 +366,18 @@ postEnv = do
             let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p
             return $ Just (p', Map.unionsWith (++) $ map (\(k, v) -> Map.singleton k [v]) f)
 
-runFormPostNoToken :: HasHandlerData env
-                   => (Html -> MForm (HandlerSite env) a)
-                   -> RIO env (a, Enctype)
+runFormPostNoToken :: MonadHandler m
+                   => (Html -> MForm m a)
+                   -> m (a, Enctype)
 runFormPostNoToken form = do
-    params <- postEnv
-    runFormGeneric (form mempty) params
+    langs <- languages
+    m <- getYesod
+    env <- postEnv
+    runFormGeneric (form mempty) m langs env
 
-runFormGet :: HasHandlerData env
-           => (Html -> MForm (HandlerSite env) a)
-           -> RIO env (a, Enctype)
+runFormGet :: MonadHandler m
+           => (Html -> MForm m a)
+           -> m (a, Enctype)
 runFormGet form = do
     gets <- liftM reqGetParams getRequest
     let env =
@@ -360,27 +391,29 @@ runFormGet form = do
 --
 -- Since 1.3.11
 generateFormGet'
-    :: HasHandlerData env
-    => (Html -> MForm (HandlerSite env) (FormResult a, xml))
-    -> RIO env (xml, Enctype)
+    :: MonadHandler m
+    => (Html -> MForm m (FormResult a, xml))
+    -> m (xml, Enctype)
 generateFormGet' form = first snd `liftM` getHelper form Nothing
 
 {-# DEPRECATED generateFormGet "Will require RenderMessage in next version of Yesod" #-}
-generateFormGet :: HasHandlerData env
-                => (Html -> MForm (HandlerSite env) a)
-                -> RIO env (a, Enctype)
+generateFormGet :: MonadHandler m
+                => (Html -> MForm m a)
+                -> m (a, Enctype)
 generateFormGet form = getHelper form Nothing
 
 getKey :: Text
 getKey = "_hasdata"
 
-getHelper :: HasHandlerData env
-          => (Html -> MForm (HandlerSite env) a)
+getHelper :: MonadHandler m
+          => (Html -> MForm m a)
           -> Maybe (Env, FileEnv)
-          -> RIO env (a, Enctype)
-getHelper form params = do
+          -> m (a, Enctype)
+getHelper form env = do
     let fragment = [shamlet|<input type=hidden name=#{getKey}>|]
-    runFormGeneric (form fragment) params
+    langs <- languages
+    m <- getYesod
+    runFormGeneric (form fragment) m langs env
 
 
 -- | Creates a hidden field on the form that identifies it.  This
@@ -405,9 +438,10 @@ getHelper form params = do
 -- even if their number or order change between the HTML
 -- generation and the form submission.
 identifyForm
-  :: Text -- ^ Form identification string.
-  -> (Html -> MForm site (FormResult a, WidgetFor site ()))
-  -> (Html -> MForm site (FormResult a, WidgetFor site ()))
+  :: Monad m
+  => Text -- ^ Form identification string.
+  -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
+  -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
 identifyForm identVal form = \fragment -> do
     -- Create hidden <input>.
     let fragment' =
@@ -424,7 +458,7 @@ identifyForm identVal form = \fragment -> do
     -- data is missing, then do not provide any params to the
     -- form, which will turn its result into FormMissing.  Also,
     -- doing this avoids having lots of fields with red errors.
-    let eraseParams | missing   = local (const Nothing)
+    let eraseParams | missing   = local (\(_, h, l) -> (Nothing, h, l))
                     | otherwise = id
     ( res', w) <- eraseParams (form fragment')
 
@@ -436,12 +470,12 @@ identifyFormKey :: Text
 identifyFormKey = "_formid"
 
 
-type FormRender site a =
-       AForm site a
+type FormRender m a =
+       AForm m a
     -> Html
-    -> MForm site (FormResult a, WidgetFor site ())
+    -> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
 
-renderTable, renderDivs, renderDivsNoLabels :: FormRender env a
+renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
 -- | Render a form into a series of tr tags. Note that, in order to allow
 -- you to add extra rows to the table, this function does /not/ wrap up
 -- the resulting HTML in a table tag; you must do that yourself.
@@ -475,7 +509,7 @@ renderDivs = renderDivsMaybeLabels True
 -- | render a field inside a div, not displaying any label
 renderDivsNoLabels = renderDivsMaybeLabels False
 
-renderDivsMaybeLabels :: Bool -> FormRender env a
+renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a
 renderDivsMaybeLabels withLabels aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
@@ -513,7 +547,7 @@ $forall view <- views
 -- >        <input .btn .primary type=submit value=_{MsgSubmit}>
 --
 -- Since 1.3.14
-renderBootstrap2 :: FormRender env a
+renderBootstrap2 :: Monad m => FormRender m a
 renderBootstrap2 aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
@@ -534,21 +568,26 @@ renderBootstrap2 aform fragment = do
                 |]
     return (res, widget)
 
-check :: RenderMessage site msg
+-- | Deprecated synonym for 'renderBootstrap2'.
+renderBootstrap :: Monad m => FormRender m a
+renderBootstrap = renderBootstrap2
+{-# DEPRECATED renderBootstrap "Please use the Yesod.Form.Bootstrap3 module." #-}
+
+check :: (Monad m, RenderMessage (HandlerSite m) msg)
       => (a -> Either msg a)
-      -> Field site a
-      -> Field site a
+      -> Field m a
+      -> Field m a
 check f = checkM $ return . f
 
 -- | Return the given error message if the predicate is false.
-checkBool :: RenderMessage site msg
-          => (a -> Bool) -> msg -> Field site a -> Field site a
+checkBool :: (Monad m, RenderMessage (HandlerSite m) msg)
+          => (a -> Bool) -> msg -> Field m a -> Field m a
 checkBool b s = check $ \x -> if b x then Right x else Left s
 
-checkM :: RenderMessage site msg
-       => (a -> HandlerFor site (Either msg a))
-       -> Field site a
-       -> Field site a
+checkM :: (Monad m, RenderMessage (HandlerSite m) msg)
+       => (a -> m (Either msg a))
+       -> Field m a
+       -> Field m a
 checkM f = checkMMap f id
 
 -- | Same as 'checkM', but modifies the datatype.
@@ -557,11 +596,11 @@ checkM f = checkMMap f id
 -- the new datatype to the old one (the second argument to this function).
 --
 -- Since 1.1.2
-checkMMap :: RenderMessage site msg
-          => (a -> HandlerFor site (Either msg b))
+checkMMap :: (Monad m, RenderMessage (HandlerSite m) msg)
+          => (a -> m (Either msg b))
           -> (b -> a)
-          -> Field site a
-          -> Field site b
+          -> Field m a
+          -> Field m b
 checkMMap f inv field = field
     { fieldParse = \ts fs -> do
         e1 <- fieldParse field ts fs
@@ -573,7 +612,7 @@ checkMMap f inv field = field
     }
 
 -- | Allows you to overwrite the error message on parse error.
-customErrorMessage :: SomeMessage site -> Field site a -> Field site a
+customErrorMessage :: Monad m => SomeMessage (HandlerSite m) -> Field m a -> Field m a
 customErrorMessage msg field = field
     { fieldParse = \ts fs ->
         liftM (either (const $ Left msg) Right)
@@ -624,10 +663,11 @@ parseHelperGen f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $
 -- > lazyTextField = convertField TL.fromStrict TL.toStrict textField
 --
 -- Since 1.3.16
-convertField :: (a -> b) -> (b -> a)
-             -> Field env a -> Field env b
-convertField to' from (Field fParse fView fEnctype) = let
-  fParse' ts = fmap (fmap (fmap to')) . fParse ts
+convertField :: (Functor m)
+             => (a -> b) -> (b -> a)
+             -> Field m a -> Field m b
+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
 

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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