Merge remote-tracking branch 'origin/master' into rio

.github/workflows/tests.yml

@@ -1,56 +0,0 @@
-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,7 +4,6 @@
 *.hi
 dist/
 dist-stack/
-stack.yaml.lock
 .stack-work
 *.swp
 client_session_key.aes
@@ -24,6 +23,4 @@ tarballs/
 .bash_history
 
 # OS X
-.DS_Store
-*.yaml.lock
-dist-newstyle/
+.DS_Store

.travis.yml

@@ -0,0 +1,174 @@
+# 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

@@ -0,0 +1,15 @@
+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 @@
-![Tests](https://github.com/yesodweb/yesod/workflows/Tests/badge.svg)
+[![Build Status](https://travis-ci.org/yesodweb/yesod.svg?branch=master)](https://travis-ci.org/yesodweb/yesod)
 
 # Yesod Web Framework
 
@@ -12,50 +12,20 @@ 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 --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
+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
 ```
 
 Each repository can be built with `stack build`.

ReleaseNotes.md

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

@@ -0,0 +1,15 @@
+# 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

@@ -1,15 +0,0 @@
-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,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -14,6 +15,7 @@ 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
@@ -35,6 +37,7 @@ 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-form for
+-- master must be able to render form messages, as we use yesod-forms for
 -- processing user input.
 class (RenderMessage master FormMessage, Yesod master) => YesodWiki master where
     -- | Write protection. By default, no protection.

stack.yaml

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

stack.yaml.lock

@@ -1,19 +0,0 @@
-# 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,17 +1,3 @@
-# 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,9 +1,10 @@
-{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 module Yesod.Auth.OAuth
     ( authOAuth
     , oauthUrl
@@ -14,13 +15,8 @@ module Yesod.Auth.OAuth
     , tumblrUrl
     , module Web.Authenticate.OAuth
     ) where
-import           Control.Applicative      as A ((<$>), (<*>))
 import           Control.Arrow            ((***))
-import           UnliftIO.Exception
-import           Control.Monad.IO.Class
-import           Data.ByteString          (ByteString)
-import           Data.Maybe
-import           Data.Text                (Text)
+import           RIO
 import qualified Data.Text                as T
 import           Data.Text.Encoding       (decodeUtf8With, encodeUtf8)
 import           Data.Text.Encoding.Error (lenientDecode)
@@ -31,7 +27,7 @@ import           Yesod.Core
 
 data YesodOAuthException = CredentialError String Credential
                          | SessionError String
-                           deriving Show
+                           deriving (Show, Typeable)
 
 instance Exception YesodOAuthException
 
@@ -54,7 +50,7 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
     dispatch
       :: Text
       -> [Text]
-      -> AuthHandler master TypedContent
+      -> SubHandlerFor Auth master TypedContent
     dispatch "GET" ["forward"] = do
         render <- getUrlRender
         tm <- getRouteToParent
@@ -77,8 +73,8 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
                                 ]
           else do
             (verifier, oaTok) <-
-                runInputGet $ (,) A.<$> ireq textField "oauth_verifier"
-                                  A.<*> ireq textField "oauth_token"
+                runInputGet $ (,) <$> ireq textField "oauth_verifier"
+                                  <*> 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,6 +1,5 @@
-cabal-version:   >= 1.10
 name:            yesod-auth-oauth
-version:         1.6.1
+version:         1.6.0.1
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
@@ -8,21 +7,27 @@ 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
-    default-language: Haskell2010
-    build-depends:   authenticate-oauth      >= 1.5       && < 1.8
-                   , base                    >= 4.10      && < 5
+    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
                    , bytestring              >= 0.9.1.4
                    , text                    >= 0.7
-                   , unliftio
+                   , rio
                    , yesod-auth              >= 1.6       && < 1.7
                    , yesod-core              >= 1.6       && < 1.7
-                   , yesod-form              >= 1.6       && < 1.8
+                   , yesod-form              >= 1.6       && < 1.7
     exposed-modules: Yesod.Auth.OAuth
     ghc-options:     -Wall
 

yesod-auth/ChangeLog.md

@@ -1,62 +1,5 @@
 # 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,7 +6,6 @@ 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://hackage.haskell.org/package/yesod-auth-bcrypt): An alternative to the HashDB module.
+* [yesod-auth-bcrypt](https://github.com/ollieh/yesod-auth-bcrypt/): An alternative to the HashDB module.

yesod-auth/Yesod/Auth.hs

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

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -1,170 +0,0 @@
-{-# 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,67 +1,25 @@
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 -- | Provides a dummy authentication module that simply lets a user specify
--- their identifier. This is not intended for real world use, just for
--- testing. This plugin supports form submissions via JSON (since 1.6.8).
---
--- = 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
-
+-- his/her identifier. This is not intended for real world use, just for
+-- testing.
 module Yesod.Auth.Dummy
     ( authDummy
     ) where
 
-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")
+import Yesod.Auth
+import Yesod.Form (runInputPost, textField, ireq)
+import Yesod.Core
 
 authDummy :: YesodAuth m => AuthPlugin m
 authDummy =
     AuthPlugin "dummy" dispatch login
   where
-    dispatch :: Text -> [Text] -> AuthHandler m TypedContent
     dispatch "POST" [] = do
-        (jsonResult :: Result Value) <- parseCheckJsonBody
-        eIdent <- case jsonResult of
-            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 []
+        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,34 +113,30 @@ module Yesod.Auth.Email
     , defaultRegisterHandler
     , defaultForgotPasswordHandler
     , defaultSetPasswordHandler
-     -- * Default helpers
-    , defaultRegisterHelper
     ) where
 
-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           Yesod.Auth
-import qualified Yesod.Auth.Message            as Msg
-import qualified Yesod.Auth.Util.PasswordStore as PS
+import qualified Yesod.Auth.Message       as Msg
 import           Yesod.Core
-import           Yesod.Core.Types              (TypedContent (TypedContent))
 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 qualified Text.Email.Validate
+import           Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
+import           Data.Maybe (isJust)
+import Data.ByteArray (convert)
 
 loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
 loginR = PluginR "email" ["login"]
@@ -214,18 +210,6 @@ 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
@@ -242,7 +226,7 @@ class ( YesodAuth site
     --
     -- @since 1.4.20
     hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
-    hashAndSaltPassword password = liftIO $ saltPass password
+    hashAndSaltPassword = liftIO . saltPass
 
     -- | Verify a password matches the stored password for the given account.
     --
@@ -343,7 +327,7 @@ class ( YesodAuth site
     -- used.
     --
     -- @since 1.6.4
-    emailPreviouslyRegisteredResponse :: MonadAuthHandler site m => Text -> Maybe (m TypedContent)
+    emailPreviouslyRegisteredResponse :: Text -> Maybe (AuthHandler site TypedContent)
     emailPreviouslyRegisteredResponse _ = Nothing
 
     -- | Additional normalization of email addresses, besides standard canonicalization.
@@ -392,8 +376,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
@@ -401,47 +385,17 @@ 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
@@ -466,7 +420,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>
@@ -488,13 +442,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
@@ -548,11 +502,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)
 
@@ -562,12 +516,12 @@ parseRegister = withObject "email" (\obj -> do
                                       pass <- obj .:? "password"
                                       return (email, pass))
 
-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
+registerHelper :: YesodAuthEmail master
+               => Bool -- ^ allow usernames?
+               -> Bool -- ^ forgot password?
+               -> Route Auth
+               -> AuthHandler master TypedContent
+registerHelper allowUsername forgotPassword dest = do
     y <- getYesod
     checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
     result <- runInputPostResult $ (,)
@@ -579,7 +533,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                  _ -> do
                      (creds :: Result Value) <- parseCheckJsonBody
                      return $ case creds of
-                                  Error _     -> Nothing
+                                  Error _ -> Nothing
                                   Success val -> parseMaybe parseRegister val
 
     let eidentifier = case creds of
@@ -592,10 +546,10 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
 
     let mpass = case (forgotPassword, creds) of
                     (False, Just (_, mp)) -> mp
-                    _                     -> Nothing
+                    _ -> Nothing
 
     case eidentifier of
-      Left failMsg -> loginErrorMessageI dest failMsg
+      Left route -> loginErrorMessageI dest route
       Right identifier -> do
             mecreds <- getEmailCreds identifier
             registerCreds <-
@@ -617,25 +571,22 @@ defaultRegisterHelper 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)
-                      if forgotPassword
-                         then sendForgotPasswordEmail email verKey verUrl
-                         else sendVerifyEmail email verKey verUrl
+                      sendVerifyEmail email verKey verUrl
                       confirmationEmailSentResponse identifier
 
 
 postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
-postRegisterR = registerHelper registerR
+postRegisterR = registerHelper False False registerR
 
 getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html
 getForgotPasswordR = forgotPasswordHandler
@@ -662,11 +613,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 =
@@ -679,7 +630,7 @@ defaultForgotPasswordHandler = do
         }
 
 postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
-postForgotPasswordR = passwordResetHelper forgotPasswordR
+postForgotPasswordR = registerHelper True True forgotPasswordR
 
 getVerifyR :: YesodAuthEmail site
            => AuthEmailId site
@@ -698,9 +649,7 @@ getVerifyR lid key hasSetPass = do
                 Just uid -> do
                     setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
                     setLoginLinkKey uid
-                    let msgAv = if hasSetPass
-                                  then Msg.EmailVerified
-                                  else Msg.EmailVerifiedChangePass
+                    let msgAv = Msg.AddressVerified
                     selectRep $ do
                       provideRep $ do
                         addMessageI "success" msgAv
@@ -742,7 +691,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
@@ -782,8 +731,8 @@ getPasswordR = do
     maid <- maybeAuthId
     case maid of
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-        Just aid -> do
-            needOld <- needOldPassword aid
+        Just _ -> do
+            needOld <- maybe (return True) needOldPassword maid
             setPasswordHandler needOld
 
 -- | Default implementation of 'setPasswordHandler'.
@@ -811,29 +760,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 =
@@ -873,7 +822,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
@@ -885,7 +834,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
@@ -904,9 +853,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"
@@ -915,7 +864,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) ->
@@ -935,7 +884,7 @@ postPasswordR = do
 
                      mr <- getMessageRender
                      selectRep $ do
-                         provideRep $
+                         provideRep $ 
                             fmap asHtml $ redirect $ afterPasswordRoute y
                          provideJsonMessage (mr msgOk)
 
@@ -979,9 +928,9 @@ loginLinkKey = "_AUTH_EMAIL_LOGIN_LINK"
 --
 -- @since 1.2.1
 --setLoginLinkKey :: (MonadHandler m) => AuthId site -> m ()
-setLoginLinkKey :: (MonadHandler m, YesodAuthEmail (HandlerSite m))
-                => AuthId (HandlerSite m)
-                -> m ()
+setLoginLinkKey :: (HasHandlerData env, YesodAuthEmail (HandlerSite env))
+                => AuthId (HandlerSite env)
+                -> RIO env ()
 setLoginLinkKey aid = do
     now <- liftIO getCurrentTime
     setSession loginLinkKey $ TS.pack $ show (toPathPiece aid, now)

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -1,616 +0,0 @@
-{-# 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,9 +131,10 @@ module Yesod.Auth.Hardcoded
   , loginR )
   where
 
-import           Yesod.Auth          (AuthHandler, AuthPlugin (..), AuthRoute,
+import           Yesod.Auth          (AuthPlugin (..), AuthRoute,
                                       Creds (..), Route (..), YesodAuth,
-                                      loginErrorMessageI, setCredsRedirect)
+                                      loginErrorMessageI, setCredsRedirect,
+                                      AuthHandler)
 import qualified Yesod.Auth.Message  as Msg
 import           Yesod.Core
 import           Yesod.Form          (ireq, runInputPost, textField)
@@ -158,9 +159,8 @@ 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,8 +40,6 @@ data AuthMessage =
     | ConfirmationEmailSentTitle
     | ConfirmationEmailSent Text
     | AddressVerified
-    | EmailVerifiedChangePass
-    | EmailVerified
     | InvalidKeyTitle
     | InvalidKey
     | InvalidEmailPass
@@ -71,7 +69,6 @@ data AuthMessage =
     | LogoutTitle
     | AuthError
 {-# DEPRECATED Logout "Please, use LogoutTitle instead." #-}
-{-# DEPRECATED AddressVerified "Please, use EmailVerifiedChangePass instead." #-}
 
 -- | Defaults to 'englishMessage'.
 defaultMessage :: AuthMessage -> Text
@@ -94,9 +91,7 @@ englishMessage (ConfirmationEmailSent email) =
     "A confirmation e-mail has been sent to " `Data.Monoid.mappend`
     email `mappend`
     "."
-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 AddressVerified = "Address verified, please set a new password"
 englishMessage InvalidKeyTitle = "Invalid verification key"
 englishMessage InvalidKey = "I'm sorry, but that was an invalid verification key."
 englishMessage InvalidEmailPass = "Invalid email/password combination"
@@ -144,8 +139,6 @@ 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"
@@ -194,8 +187,6 @@ 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"
@@ -244,8 +235,6 @@ 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"
@@ -282,21 +271,19 @@ germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"
 germanMessage LoginOpenID = "Login via OpenID"
 germanMessage LoginGoogle = "Login via Google"
 germanMessage LoginYahoo = "Login via Yahoo"
-germanMessage Email = "E-Mail"
-germanMessage UserName = "Benutzername"
+germanMessage Email = "Email"
+germanMessage UserName = "Benutzername" -- FIXME by Google Translate "user name"
 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"
@@ -308,23 +295,24 @@ 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 = "Anmelden"
+germanMessage LoginTitle = "Log In"
 germanMessage PleaseProvideUsername = "Bitte Nutzername angeben"
 germanMessage PleaseProvidePassword = "Bitte Passwort angeben"
-germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben"
-germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter"
+germanMessage NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben"
+germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter"
 germanMessage PasswordResetTitle = "Passwort zurücksetzen"
-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 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 InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"
-germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO
-germanMessage Logout = "Abmelden"
-germanMessage LogoutTitle = "Abmelden"
-germanMessage AuthError = "Fehler beim Anmelden"
+-- 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
 
 frenchMessage :: AuthMessage -> Text
 frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"
@@ -344,8 +332,6 @@ 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."
@@ -393,8 +379,6 @@ 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"
@@ -443,8 +427,6 @@ japaneseMessage (ConfirmationEmailSent email) =
     email `mappend`
     " に送信しました"
 japaneseMessage AddressVerified = "アドレスは認証されました。新しいパスワードを設定してください"
-japaneseMessage EmailVerifiedChangePass = "アドレスは認証されました。新しいパスワードを設定してください"
-japaneseMessage EmailVerified = "アドレスは認証されました"
 japaneseMessage InvalidKeyTitle = "認証キーが無効です"
 japaneseMessage InvalidKey = "申し訳ありません。無効な認証キーです"
 japaneseMessage InvalidEmailPass = "メールアドレスまたはパスワードが無効です"
@@ -494,8 +476,6 @@ 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."
@@ -544,8 +524,6 @@ chineseMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 chineseMessage AddressVerified = "地址验证成功，请设置新密码"
-chineseMessage EmailVerifiedChangePass = "地址验证成功，请设置新密码"
-chineseMessage EmailVerified = "地址验证成功"
 chineseMessage InvalidKeyTitle = "无效的验证码"
 chineseMessage InvalidKey = "对不起，验证码无效。"
 chineseMessage InvalidEmailPass = "无效的邮箱/密码组合"
@@ -591,8 +569,6 @@ 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"
@@ -633,7 +609,7 @@ russianMessage LoginYahoo = "Вход с помощью Yahoo"
 russianMessage Email = "Эл.почта"
 russianMessage UserName = "Имя пользователя"
 russianMessage Password = "Пароль"
-russianMessage CurrentPassword = "Старый пароль"
+russianMessage CurrentPassword = "Current password"
 russianMessage Register = "Регистрация"
 russianMessage RegisterLong = "Создать учётную запись"
 russianMessage EnterEmail = "Введите свой адрес эл.почты ниже, вам будет отправлено письмо для подтверждения."
@@ -643,8 +619,6 @@ russianMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 russianMessage AddressVerified = "Адрес подтверждён. Пожалуйста, установите новый пароль."
-russianMessage EmailVerifiedChangePass = "Адрес подтверждён. Пожалуйста, установите новый пароль."
-russianMessage EmailVerified = "Адрес подтверждён"
 russianMessage InvalidKeyTitle = "Неверный ключ подтверждения"
 russianMessage InvalidKey = "Извините, но ключ подтверждения оказался недействительным."
 russianMessage InvalidEmailPass = "Неверное сочетание эл.почты и пароля"
@@ -692,8 +666,6 @@ 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"
@@ -741,8 +713,6 @@ 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"
@@ -787,8 +757,6 @@ 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"
@@ -836,8 +804,6 @@ koreanMessage (ConfirmationEmailSent email) =
     email `mappend`
     "에 보냈습니다."
 koreanMessage AddressVerified = "주소가 인증되었습니다. 새 비밀번호를 설정하세요."
-koreanMessage EmailVerifiedChangePass = "주소가 인증되었습니다. 새 비밀번호를 설정하세요."
-koreanMessage EmailVerified = "주소가 인증되었습니다"
 koreanMessage InvalidKeyTitle = "인증키가 잘못되었습니다"
 koreanMessage InvalidKey = "죄송합니다. 잘못된 인증키입니다."
 koreanMessage InvalidEmailPass = "이메일 주소나 비밀번호가 잘못되었습니다"

yesod-auth/Yesod/Auth/OpenId.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Yesod.Auth.OpenId
     ( authOpenId
     , forwardUrl
@@ -29,7 +30,7 @@ forwardUrl = PluginR "openid" ["forward"]
 
 data IdentifierType = Claimed | OPLocal
 
-authOpenId :: YesodAuth master
+authOpenId :: forall master. YesodAuth master
            => IdentifierType
            -> [(Text, Text)] -- ^ extension fields
            -> AuthPlugin master
@@ -41,16 +42,15 @@ authOpenId idType extensionFields =
     name :: Text
     name = "openid_identifier"
 
+    login
+      :: (AuthRoute -> Route master)
+      -> WidgetFor master ()
     login tm = do
         ident <- newIdent
-        -- 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}
+        toWidget [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,7 +62,10 @@ $newline never
     <input type="submit" value="_{Msg.LoginOpenID}">
 |]
 
-    dispatch :: Text -> [Text] -> AuthHandler master TypedContent
+    dispatch
+      :: Text
+      -> [Text]
+      -> SubHandlerFor Auth master TypedContent
     dispatch "GET" ["forward"] = do
         roid <- runInputGet $ iopt textField name
         case roid of
@@ -86,7 +89,11 @@ $newline never
         completeHelper idType posts
     dispatch _ _ = notFound
 
-completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
+completeHelper
+  :: (HasHandlerData env, SubHandlerSite env ~ Auth, YesodAuth (HandlerSite env))
+  => IdentifierType
+  -> [(Text, Text)]
+  -> RIO env TypedContent
 completeHelper idType gets' = do
     manager <- authHttpManager
     eres <- tryAny $ OpenId.authenticateClaimed gets' manager

yesod-auth/Yesod/Auth/Routes.hs

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

yesod-auth/Yesod/Auth/Rpxnow.hs

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

yesod-auth/yesod-auth.cabal

@@ -1,6 +1,5 @@
-cabal-version:   >=1.10
 name:            yesod-auth
-version:         1.6.11.2
+version:         1.6.6
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -8,6 +7,7 @@ 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,10 +20,8 @@ flag network-uri
   default: True
 
 library
-    default-language: Haskell2010
-    build-depends:   base                    >= 4.10      && < 5
+    build-depends:   base                    >= 4         && < 5
                    , aeson                   >= 0.7
-                   , attoparsec-aeson        >= 2.1
                    , authenticate            >= 1.3.4
                    , base16-bytestring
                    , base64-bytestring
@@ -45,8 +43,9 @@ library
                    , http-types
                    , memory
                    , nonce                   >= 1.0.2     && < 1.1
-                   , persistent              >= 2.8
+                   , persistent              >= 2.8       && < 2.10
                    , random                  >= 1.0.0.2
+                   , rio
                    , safe
                    , shakespeare
                    , template-haskell
@@ -58,20 +57,18 @@ library
                    , unordered-containers
                    , wai                     >= 1.4
                    , yesod-core              >= 1.6       && < 1.7
-                   , yesod-form              >= 1.6       && < 1.8
+                   , yesod-form              >= 1.6       && < 1.7
                    , 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,18 +9,13 @@ 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(3, 7, 0)
-import Distribution.Simple.PackageDescription (readGenericPackageDescription)
-#elif MIN_VERSION_Cabal(2, 2, 0)
+#if 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)
@@ -67,18 +62,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): "
@@ -89,22 +84,13 @@ 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
-    routesPath <- getRoutesFilePath
-    modify routesPath $ fixRoutes name pattern methods
+    modify "config/routes" $ fixRoutes name pattern methods
     writeFile handlerFile $ mkHandler name pattern methods
     specExists <- doesFileExist specFile
     unless specExists $
@@ -252,8 +238,4 @@ 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,33 +1,3 @@
-# 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,9 +28,6 @@ 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
@@ -59,7 +56,7 @@ import           Network.Wai                           (requestHeaderHost,
                                                         responseLBS)
 import           Network.Wai.Handler.Warp              (defaultSettings, runSettings,
                                                         setPort, setHost)
-import           Network.Wai.Handler.WarpTLS           (runTLS, tlsSettings,
+import           Network.Wai.Handler.WarpTLS           (runTLS,
                                                         tlsSettingsMemory)
 import           Network.Wai.Parse                     (parseHttpAccept)
 import           Say
@@ -129,7 +126,6 @@ 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
@@ -139,7 +135,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) =
@@ -174,12 +170,10 @@ reverseProxy opts appPortVar = do
                 manager
         defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings
         runProxyTls port app = 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 cert = $(embedFile "certificate.pem")
+              key = $(embedFile "key.pem")
+              tlsSettings = tlsSettingsMemory cert key
+          runTLS tlsSettings (setPort port defaultSettings') $ \req send -> do
             let req' = req
                     { requestHeaders
                         = ("X-Forwarded-Proto", "https")
@@ -292,9 +286,7 @@ devel opts passThroughArgs = do
 
     -- Find out the name of our package, needed for the upcoming Stack
     -- commands
-#if MIN_VERSION_Cabal(3, 0, 0)
-    cabal  <- D.tryFindPackageDesc D.silent "."
-#elif MIN_VERSION_Cabal(1, 20, 0)
+#if MIN_VERSION_Cabal(1, 20, 0)
     cabal  <- D.tryFindPackageDesc "."
 #else
     cabal  <- D.findPackageDesc "."
@@ -351,8 +343,7 @@ devel opts passThroughArgs = do
         myPath <- getExecutablePath
         let procConfig = setStdout createSource
                        $ setStderr createSource
-                       $ setCreateGroup True -- because need when yesod-bin killed and kill child ghc
-                       $ proc "stack" $
+                       $ setDelegateCtlc True $ proc "stack" $
                 [ "build"
                 , "--fast"
                 , "--file-watch"

yesod-bin/Keter.hs

@@ -1,16 +1,10 @@
 {-# 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,7 +83,6 @@ 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,13 +30,12 @@ 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
@@ -91,7 +90,6 @@ main = do
                              , proxyTimeout = proxyTimeout
                              , useReverseProxy = not noReverseProxy
                              , develHost    = develHost
-                             , cert         = cert
                              } develExtraArgs
     DevelSignal     -> develSignal
   where
@@ -169,11 +167,6 @@ 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.2.2
+version:         1.6.0.3
 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.10
+cabal-version:   >= 1.6
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 
@@ -19,13 +19,12 @@ 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.10         && < 5
+    build-depends:     base               >= 4.3          && < 5
                      , Cabal              >= 1.18
                      , bytestring         >= 0.9.1.4
                      , conduit            >= 1.3
@@ -35,7 +34,7 @@ executable             yesod
                      , directory          >= 1.2.1
                      , file-embed
                      , filepath           >= 1.1
-                     , fsnotify
+                     , fsnotify           >= 0.0          && < 0.4
                      , http-client        >= 0.4.7
                      , http-client-tls
                      , http-reverse-proxy >= 0.4
@@ -61,7 +60,6 @@ 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,155 +1,8 @@
 # ChangeLog for yesod-core
 
-## 1.6.25.1
+## 2.0.0.0
 
-* 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)
+* Switch over to using `rio`
 
 ## 1.6.13
 

yesod-core/src/Yesod/Core.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module Yesod.Core
     ( -- * Type classes
@@ -29,10 +30,6 @@ module Yesod.Core
     , AuthResult (..)
     , unauthorizedI
       -- * Logging
-    , defaultMakeLogger
-    , defaultMessageLoggerSource
-    , defaultShouldLogIO
-    , formatLogMessage
     , LogLevel (..)
     , logDebug
     , logInfo
@@ -67,8 +64,10 @@ module Yesod.Core
     , ScriptLoadPosition (..)
     , BottomOfHeadAsync
     -- * Generalizing type classes
-    , MonadHandler (..)
-    , MonadWidget (..)
+    , HasHandlerData (..)
+    , HasWidgetData (..)
+    , liftHandler
+    , liftWidget
       -- * Approot
     , guessApproot
     , guessApprootOr
@@ -76,7 +75,6 @@ module Yesod.Core
       -- * Misc
     , yesodVersion
     , yesodRender
-    , Yesod.Core.runFakeHandler
       -- * LiteApp
     , module Yesod.Core.Internal.LiteApp
       -- * Low-level
@@ -94,12 +92,9 @@ module Yesod.Core
     , MonadIO (..)
     , MonadUnliftIO (..)
     , MonadResource (..)
-    , MonadLogger
+    , RIO
       -- * Commonly referenced functions/datatypes
     , Application
-      -- * Utilities
-    , showIntegral
-    , readIntegral
       -- * Shakespeare
       -- ** Hamlet
     , hamlet
@@ -120,7 +115,6 @@ 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
@@ -128,18 +122,16 @@ import Text.Shakespeare.I18N
 import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)
 import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)
 
-import Control.Monad.Logger
 import Control.Monad.Trans.Class (MonadTrans (..))
 import Yesod.Core.Internal.Session
 import Yesod.Core.Internal.Run (yesodRunner, yesodRender)
 import Yesod.Core.Class.Yesod
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Class.Breadcrumbs
-import qualified Yesod.Core.Internal.Run
 import qualified Paths_yesod_core
 import Data.Version (showVersion)
 import Yesod.Routes.Class
-import UnliftIO (MonadIO (..), MonadUnliftIO (..))
+import RIO
 
 import Control.Monad.Trans.Resource (MonadResource (..))
 import Yesod.Core.Internal.LiteApp
@@ -149,17 +141,11 @@ import Text.Lucius
 import Text.Julius
 import Network.Wai (Application)
 
-runFakeHandler :: (Yesod site, MonadIO m) =>
-                  SessionMap
-               -> (site -> Logger)
-               -> site
-               -> HandlerT site IO a
-               -> m (Either ErrorResponse a)
-runFakeHandler = Yesod.Core.Internal.Run.runFakeHandler
-{-# DEPRECATED runFakeHandler "import runFakeHandler from Yesod.Core.Unsafe" #-}
-
 -- | Return an 'Unauthorized' value, with the given i18n message.
-unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult
+unauthorizedI
+  :: (HasHandlerData env, RenderMessage (HandlerSite env) msg)
+  => msg
+  -> RIO env AuthResult
 unauthorizedI msg = do
     mr <- getMessageRender
     return $ Unauthorized $ mr msg
@@ -178,12 +164,3 @@ 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,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
 module Yesod.Core.Class.Breadcrumbs where
 
 import Yesod.Core.Handler
@@ -16,7 +15,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, Show (Route site), Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)])
+breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)])
 breadcrumbs = do
     x <- getCurrentRoute
     case x of
@@ -27,8 +26,6 @@ breadcrumbs = do
             return (title, z)
   where
     go back Nothing = return back
-    go back (Just this)
-      | this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this
-      | otherwise = do
-          (title, next) <- breadcrumb this
-          go ((this, title) : back) next
+    go back (Just this) = do
+        (title, next) <- breadcrumb this
+        go ((this, title) : back) next

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

@@ -4,8 +4,10 @@
 {-# 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 (..))
@@ -30,8 +32,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
@@ -39,14 +41,15 @@ subHelper
   -> YesodSubRunnerEnv child master
   -> Maybe (Route child)
   -> W.Application
-subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =
+subHelper subHandler YesodSubRunnerEnv {..} mroute =
     ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)
   where
-    handler = fmap toTypedContent $ HandlerFor $ \hd ->
+    handler = fmap toTypedContent $ do
+      hd <- view subHandlerDataL
       let rhe = handlerEnv hd
           rhe' = rhe
             { rheRoute = mroute
             , rheChild = ysreGetSub $ yreSite ysreParentEnv
             , rheRouteToMaster = ysreToParentRoute
             }
-       in f hd { handlerEnv = rhe' }
+      runRIO hd { handlerEnv = rhe' } subHandler

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

@@ -1,126 +0,0 @@
-{-# 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,12 @@
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE TemplateHaskell     #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE TemplateHaskell   #-}
 module Yesod.Core.Class.Yesod where
 
+import           RIO
+
 import           Yesod.Core.Content
 import           Yesod.Core.Handler
 
@@ -14,11 +15,6 @@ 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
@@ -32,15 +28,12 @@ import qualified Data.Text                          as T
 import qualified Data.Text.Encoding                 as TE
 import qualified Data.Text.Encoding.Error           as TEE
 import           Data.Text.Lazy.Builder             (toLazyText)
-import           Data.Text.Lazy.Encoding            (encodeUtf8)
-import           Data.Word                          (Word64)
+import qualified Data.Text.Lazy.Encoding            as TLE (encodeUtf8)
 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)
@@ -54,10 +47,7 @@ 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.
@@ -74,16 +64,6 @@ 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'.
@@ -101,8 +81,6 @@ 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
@@ -231,29 +209,15 @@ class RenderRoute site => Yesod site where
     maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)
     maximumContentLengthIO a b = pure $ maximumContentLength a b
 
-    -- | Creates a @Logger@ to use for log messages.
+    -- | Get the 'LogFunc' from the foundation type.
     --
-    -- 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
+    -- 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
 
     -- | Where to Load sripts from. We recommend the default value,
     -- 'BottomOfBody'.
@@ -265,16 +229,6 @@ 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
@@ -294,14 +248,6 @@ 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.
     --
@@ -338,44 +284,6 @@ 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.
@@ -444,12 +352,10 @@ 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"
-              $ T.pack $ concat [ "max-age="
-                                , show $ timeout * 60
-                                , "; includeSubDomains"
-                                ]
+              $ utf8BuilderToText -- FIXME should we store headers as Utf8Builders?
+              $ "max-age=" <> display (timeout' * 60) <> "; includeSubDomains"
     handler
 
 -- | Check if a given request is authorized via 'isAuthorized' and
@@ -475,7 +381,7 @@ authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
                               void $ redirect url'
                           provideRepType typeJson $
                               void notAuthenticated
-            Unauthorized s' -> permissionDenied s'
+            Unauthorized s' -> permissionDenied $ display s'
 
 -- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
 --
@@ -547,21 +453,16 @@ widgetToPageContent :: Yesod site
                     => WidgetFor site ()
                     -> HandlerFor site (PageContent (Route site))
 widgetToPageContent w = do
- jsAttrs <- jsAttributesHandler
- HandlerFor $ \hd -> do
-  master <- unHandlerFor getYesod hd
+  master <- getYesod
   ref <- newIORef mempty
-  unWidgetFor w WidgetData
-    { wdRef = ref
-    , wdHandler = hd
-    }
-  GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref
+  hd <- ask
+  runRIO WidgetData { wdRef = ref, wdHandler = hd } w
+  GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref
   let title = maybe mempty unTitle mTitle
-      description = unDescription <$> mDescription
       scripts = runUniqueList scripts'
       stylesheets = runUniqueList stylesheets'
 
-  flip unHandlerFor hd $ do
+  do -- just to reduce whitespace diffs
     render <- getUrlRenderParams
     let renderLoc x =
             case x of
@@ -571,7 +472,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"
-           $ encodeUtf8 rendered
+           $ TLE.encodeUtf8 $ rendered
         return (mmedia,
             case x of
                 Nothing -> Left $ preEscapedToMarkup rendered
@@ -581,7 +482,7 @@ widgetToPageContent w = do
             Nothing -> return Nothing
             Just s -> do
                 x <- addStaticContent "js" "text/javascript; charset=utf-8"
-                   $ encodeUtf8 $ renderJavascriptUrl render s
+                   $ TLE.encodeUtf8 $ renderJavascriptUrl render s
                 return $ renderLoc x
 
     -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing
@@ -593,7 +494,7 @@ widgetToPageContent w = do
                 ^{mkScriptTag s}
             $maybe j <- jscript
                 $maybe s <- jsLoc
-                    <script src="#{s}" *{jsAttrs}>
+                    <script src="#{s}" *{jsAttributes master}>
                 $nothing
                     <script>^{jelper j}
         |]
@@ -627,7 +528,7 @@ widgetToPageContent w = do
             ^{regularScriptLoad}
         |]
 
-    return $ PageContent title description headAll $
+    return $ PageContent title headAll $
         case jsLoader master of
             BottomOfBody -> bodyScript
             _ -> body
@@ -656,7 +557,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,
@@ -680,7 +581,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
@@ -699,10 +600,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" e
+    logErrorS "yesod-core" $ display e
     selectRep $ do
         provideRep $ defaultLayout $ defaultMessageWidget
             "Internal Server Error"
@@ -740,43 +641,6 @@ 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,7 +64,6 @@ 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)
@@ -104,14 +103,10 @@ 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
@@ -165,8 +160,6 @@ 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
@@ -279,8 +272,6 @@ 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
@@ -301,8 +292,6 @@ 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,6 +3,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 module Yesod.Core.Dispatch
     ( -- * Quasi-quoted routing
       parseRoutes
@@ -10,24 +11,13 @@ 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 (..)
@@ -49,7 +39,6 @@ module Yesod.Core.Dispatch
 
 import Prelude hiding (exp)
 import Yesod.Core.Internal.TH
-import Language.Haskell.TH.Syntax (qLocation)
 
 import Web.PathPieces
 
@@ -57,7 +46,6 @@ 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
@@ -71,7 +59,7 @@ import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
 import Text.Read (readMaybe)
 import System.Environment (getEnvironment)
-import System.Entropy (getEntropy)
+import qualified System.Random as Random
 import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
 import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
 
@@ -80,45 +68,47 @@ 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
-    logger <- makeLogger site
+    (logFunc, cleanup) <- makeLogFunc site
     sb <- makeSessionBackend site
     getMaxExpires <- getGetMaxExpires
     return $ toWaiAppYre YesodRunnerEnv
-            { yreLogger = logger
+            { yreLogFunc = logFunc
             , 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 = bsToInt <$> getEntropy bytes
-  where
-    bits = finiteBitSize (undefined :: Int)
-    bytes = div (bits + 7) 8
-    bsToInt = S.foldl' (\v i -> shiftL v 8 .|. fromIntegral i) 0
+defaultGen = Random.getStdRandom Random.next
 
 -- | Pure low level function to construct WAI application. Usefull
 -- when you need not standard way to run your app, or want to embed it
@@ -168,28 +158,28 @@ toWaiAppYre yre req =
 -- * Accept header override with the _accept query string parameter
 toWaiApp :: YesodDispatch site => site -> IO W.Application
 toWaiApp site = do
-    logger <- makeLogger site
-    toWaiAppLogger logger site
+    (logFunc, cleanup) <- makeLogFunc site
+    toWaiAppLogger logFunc cleanup site
 
-toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
-toWaiAppLogger logger site = do
+toWaiAppLogger
+  :: YesodDispatch site
+  => LogFunc
+  -> IORef () -- ^ cleanup
+  -> site
+  -> IO W.Application
+toWaiAppLogger logFunc cleanup site = do
     sb <- makeSessionBackend site
     getMaxExpires <- getGetMaxExpires
     let yre = YesodRunnerEnv
-                { yreLogger = logger
+                { yreLogFunc = logFunc
                 , yreSite = site
                 , yreSessionBackend = sb
                 , yreGen = defaultGen
                 , yreGetMaxExpires = getMaxExpires
+                , yreCleanup = cleanup
                 }
-    messageLoggerSource
-        site
-        logger
-        $(qLocation >>= liftLoc)
-        "yesod-core"
-        LevelInfo
-        (toLogStr ("Application launched" :: S.ByteString))
-    middleware <- mkDefaultMiddlewares logger
+    runRIO logFunc $ logInfoS "yesod-core" "Application launched"
+    middleware <- mkDefaultMiddlewares logFunc
     return $ middleware $ toWaiAppYre yre
 
 -- | A convenience method to run an application using the Warp webserver on the
@@ -197,35 +187,21 @@ toWaiAppLogger logger site = do
 -- middlewares. This set may change at any point without a breaking version
 -- number. Currently, it includes:
 --
--- * Logging
---
--- * GZIP compression
---
--- * Automatic HEAD method handling
---
--- * Request method override with the _method query string parameter
---
--- * Accept header override with the _accept query string parameter
---
 -- If you need more fine-grained control of middlewares, please use 'toWaiApp'
 -- directly.
 --
 -- Since 1.2.0
 warp :: YesodDispatch site => Int -> site -> IO ()
 warp port site = do
-    logger <- makeLogger site
-    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings (
+    (logFunc, cleanup) <- makeLogFunc site
+    toWaiAppLogger logFunc cleanup site >>= Network.Wai.Handler.Warp.runSettings (
         Network.Wai.Handler.Warp.setPort port $
         Network.Wai.Handler.Warp.setServerName serverValue $
         Network.Wai.Handler.Warp.setOnException (\_ e ->
                 when (shouldLog' e) $
-                messageLoggerSource
-                    site
-                    logger
-                    $(qLocation >>= liftLoc)
-                    "yesod-core"
-                    LevelError
-                    (toLogStr $ "Exception from Warp: " ++ show e))
+                runRIO logFunc $
+                logErrorS "yesod-core" $
+                "Exception from Warp: " <> displayShow e)
         Network.Wai.Handler.Warp.defaultSettings)
   where
     shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException
@@ -242,10 +218,14 @@ serverValue = S8.pack $ concat
 -- | A default set of middlewares.
 --
 -- Since 1.2.0
-mkDefaultMiddlewares :: Logger -> IO W.Middleware
-mkDefaultMiddlewares logger = do
+mkDefaultMiddlewares :: LogFunc -> IO W.Middleware
+mkDefaultMiddlewares logFunc = do
     logWare <- mkRequestLogger def
-        { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger
+        { destination = Network.Wai.Middleware.RequestLogger.Callback $
+            runRIO logFunc .
+            logInfoS "yesod-core" .
+            displayBytesUtf8 .
+            fromLogStr
         , 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 40
+                Nothing -> Right $ fmap Just . randomString 10
         | otherwise = Left Nothing
 
 textQueryString :: W.Request -> [(Text, Text)]

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

@@ -1,38 +1,21 @@
-{-# 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
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards     #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE FlexibleContexts  #-}
+module Yesod.Core.Internal.Run where
 
-import qualified Control.Exception as EUnsafe
+
+import           RIO
 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)
@@ -40,11 +23,9 @@ 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
@@ -53,9 +34,6 @@ 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
@@ -84,13 +62,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 <- I.newIORef defState
+    istate <- newIORef defState
 
     -- Run the handler itself, capturing any runtime exceptions and
     -- converting them into a @HandlerContents@
-    contents' <- rheCatchHandlerExceptions rhe
+    contents' <- catchAny
         (do
-            res <- unHandlerFor handler (hd istate)
+            res <- runRIO (hd istate) handler
             tc <- evaluate (toTypedContent res)
             -- Success! Wrap it up in an @HCContent@
             return (HCContent defaultStatus tc))
@@ -100,7 +78,7 @@ basicRunHandler rhe handler yreq resState = do
                 Nothing -> HCError <$> toErrorHandler e)
 
     -- Get the raw state and return
-    state <- I.readIORef istate
+    state <- readIORef istate
     return (state, contents')
   where
     defState = GHState
@@ -111,7 +89,7 @@ basicRunHandler rhe handler yreq resState = do
         , ghsCacheBy = mempty
         , ghsHeaders = mempty
         }
-    hd istate = HandlerData
+    hd istate = HandlerData $ SubHandlerData
         { handlerRequest = yreq
         , handlerEnv     = rhe
         , handlerState   = istate
@@ -189,19 +167,16 @@ 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)
-             => (forall a. IO a -> (SomeException -> IO a) -> IO a)
-             -> HandlerContents
+             => HandlerContents
              -> w
              -> IO (w, HandlerContents)
-evalFallback catcher contents val = catcher
+evalFallback contents val = catchAny
     (fmap (, contents) (evaluate $!! val))
     (fmap ((mempty, ) . HCError) . toErrorHandler)
 
 -- | Function used internally by Yesod in the process of converting a
--- 'HandlerFor' into an 'Application'. Should not be needed by users.
+-- 'HandlerT' into an 'Application'. Should not be needed by users.
 runHandler :: ToTypedContent c
            => RunHandlerEnv site site
            -> HandlerFor site c
@@ -212,8 +187,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
 
     -- Evaluate the unfortunately-lazy session and headers,
     -- propagating exceptions into the contents
-    (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)
-    (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
+    (finalSession, contents1) <- evalFallback contents0 (ghsSession state)
+    (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
     contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
 
     -- Convert the HandlerContents into the final YesodResponse
@@ -223,12 +198,11 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
         headers
         contents3
 
-safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-       -> ErrorResponse
-       -> YesodApp
-safeEh log' er req = do
-    liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError
-           $ toLogStr $ "Error handler errored out: " ++ show er
+safeEh :: LogFunc -> ErrorResponse -> YesodApp
+safeEh logFunc er req = do
+    runRIO logFunc $
+      logErrorS "yesod-core" $
+      "Error handler errored out: " <> displayShow er
     return $ YRPlain
         H.status500
         []
@@ -236,36 +210,36 @@ safeEh log' er req = do
         (toContent ("Internal Server Error" :: S.ByteString))
         (reqSession req)
 
--- | Run a 'HandlerFor' completely outside of Yesod.  This
+-- | Run a 'HandlerT' completely outside of Yesod.  This
 -- function comes with many caveats and you shouldn't use it
 -- unless you fully understand what it's doing and how it works.
 --
 -- As of now, there's only one reason to use this function at
--- all: in order to run unit tests of functions inside 'HandlerFor'
+-- all: in order to run unit tests of functions inside 'HandlerT'
 -- but that aren't easily testable with a full HTTP request.
 -- Even so, it's better to use @wai-test@ or @yesod-test@ instead
 -- of using this function.
 --
 -- This function will create a fake HTTP request (both @wai@'s
 -- 'Request' and @yesod@'s 'Request') and feed it to the
--- @HandlerFor@.  The only useful information the @HandlerFor@ may
+-- @HandlerT@.  The only useful information the @HandlerT@ may
 -- get from the request is the session map, which you must supply
 -- as argument to @runFakeHandler@.  All other fields contain
 -- fake information, which means that they can be accessed but
 -- won't have any useful information.  The response of the
--- @HandlerFor@ is completely ignored, including changes to the
+-- @HandlerT@ is completely ignored, including changes to the
 -- session, cookies or headers.  We only return you the
--- @HandlerFor@'s return value.
-runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
+-- @HandlerT@'s return value.
+runFakeHandler :: (Yesod site, MonadIO m) =>
                   SessionMap
-               -> (site -> Logger)
+               -> LogFunc
                -> site
                -> HandlerFor site a
                -> m (Either ErrorResponse a)
-runFakeHandler fakeSessionMap logger site handler = liftIO $ do
-  ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
+runFakeHandler fakeSessionMap logFunc site handler = liftIO $ do
+  ret <- newIORef (Left $ InternalError "runFakeHandler: no result")
   maxExpires <- getCurrentMaxExpiresRFC1123
-  let handler' = liftIO . I.writeIORef ret . Right =<< handler
+  let handler' = writeIORef ret . Right =<< handler
   let yapp = runHandler
          RunHandlerEnv
             { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
@@ -274,14 +248,13 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
             , rheChild = site
             , rheSite = site
             , rheUpload = fileUpload site
-            , rheLog = messageLoggerSource site $ logger site
+            , rheLogFunc = logFunc
             , rheOnError = errHandler
             , rheMaxExpires = maxExpires
-            , rheCatchHandlerExceptions = catchHandlerExceptions site
             }
         handler'
       errHandler err req = do
-          liftIO $ I.writeIORef ret (Left err)
+          writeIORef ret (Left err)
           return $ YRPlain
                      H.status500
                      []
@@ -317,9 +290,9 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
           , reqSession    = fakeSessionMap
           }
   _ <- runResourceT $ yapp fakeRequest
-  I.readIORef ret
+  readIORef ret
 
-yesodRunner :: forall res site . (ToTypedContent res, Yesod site)
+yesodRunner :: (ToTypedContent res, Yesod site)
             => HandlerFor site res
             -> YesodRunnerEnv site
             -> Maybe (Route site)
@@ -339,8 +312,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
                   Left yreq' -> yreq'
                   Right needGen -> needGen yreGen
       let ra = resolveApproot yreSite req
-      let log' = messageLoggerSource yreSite yreLogger
-          -- We set up two environments: the first one has a "safe" error handler
+      let -- 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.
@@ -351,10 +323,9 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
               , rheChild = yreSite
               , rheSite = yreSite
               , rheUpload = fileUpload yreSite
-              , rheLog = log'
-              , rheOnError = safeEh log'
+              , rheLogFunc = yreLogFunc
+              , rheOnError = safeEh yreLogFunc
               , rheMaxExpires = maxExpires
-              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite
               }
           rhe = rheSafe
               { rheOnError = runHandler rheSafe . errorHandler

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

@@ -1,48 +1,10 @@
-{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# 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
+module Yesod.Core.Internal.TH where
 
 import Prelude hiding (exp)
 import Yesod.Core.Handler
@@ -60,7 +22,6 @@ 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
@@ -74,17 +35,7 @@ import Yesod.Core.Internal.Run
 mkYesod :: String -- ^ name of the argument datatype
         -> [ResourceTree String]
         -> Q [Dec]
-mkYesod = mkYesodOpts defaultOpts
-
--- | `mkYesod` but with custom options.
---
--- @since 1.6.25.0
-mkYesodOpts :: RouteOpts
-            -> String
-            -> [ResourceTree String]
-            -> Q [Dec]
-mkYesodOpts opts name = fmap (uncurry (++)) . mkYesodWithParserOpts opts name False return
-
+mkYesod name = fmap (uncurry (++)) . mkYesodWithParser 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. 
@@ -97,30 +48,15 @@ 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 = 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
-
+mkYesodData name resS = fst <$> mkYesodWithParser name False return resS
 
 mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodSubData = mkYesodSubDataOpts defaultOpts
-
--- |
---
--- @since 1.6.25.0
-mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
-mkYesodSubDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name True return resS
-
+mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS
 
 -- | Parses contexts and type arguments out of name before generating TH.
 mkYesodWithParser :: String                    -- ^ foundation type
@@ -128,22 +64,11 @@ mkYesodWithParser :: String                    -- ^ foundation type
                   -> (Exp -> Q Exp)            -- ^ unwrap handler
                   -> [ResourceTree String]
                   -> Q([Dec],[Dec])
-mkYesodWithParser = mkYesodWithParserOpts defaultOpts
-
--- | Parses contexts and type arguments out of name before generating TH.
---
--- @since 1.6.25.0
-mkYesodWithParserOpts :: RouteOpts                 -- ^ Additional route options
-                      -> String                    -- ^ foundation type
-                      -> Bool                      -- ^ is this a subsite
-                      -> (Exp -> Q Exp)            -- ^ unwrap handler
-                      -> [ResourceTree String]
-                      -> Q([Dec],[Dec])
-mkYesodWithParserOpts opts name isSub f resS = do
+mkYesodWithParser name isSub f resS = do
     let (name', rest, cxt) = case parse parseName "" name of
             Left err -> error $ show err
             Right a -> a
-    mkYesodGeneralOpts opts cxt name' rest isSub f resS
+    mkYesodGeneral cxt name' rest isSub f resS
 
     where
         parseName = do
@@ -175,28 +100,19 @@ mkYesodWithParserOpts opts name isSub f resS = do
         parseContexts = 
             sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
 
-
 -- | See 'mkYesodData'.
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodDispatch = mkYesodDispatchOpts defaultOpts
-
--- | See 'mkYesodDataOpts'
---
--- @since 1.6.25.0
-mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
-mkYesodDispatchOpts opts name = fmap snd . mkYesodWithParserOpts opts name False return
-
+mkYesodDispatch name = fmap snd . mkYesodWithParser 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
@@ -204,20 +120,7 @@ mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in Ren
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-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
+mkYesodGeneral appCxt' namestr mtys isSub f resS = do
     let appCxt = fmap (\(c:rest) -> 
             foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
           ) appCxt'
@@ -238,14 +141,11 @@ mkYesodGeneralOpts opts 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"
-    -- types that you apply to get a concrete site name
-    let argtypes = fmap nameToType mtys ++ fmap VarT vns
-    -- 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
+    let argtypes = fmap nameToType mtys ++ fmap VarT vns
+        site = foldl' AppT (ConT name) argtypes
         res = map (fmap (parseType . dropBracket)) resS
-    renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res
+    renderRouteDec <- mkRenderRouteInstance appCxt site res
     routeAttrsDec  <- mkRouteAttrsInstance appCxt site res
     dispatchDec    <- mkDispatchInstance site appCxt f res
     parseRoute <- mkParseRouteInstance appCxt site res
@@ -260,15 +160,22 @@ mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
             , renderRouteDec
             , [routeAttrsDec]
             , resourcesDec
-            , if isSub then [] else masterTypeSyns argvars site
+            , if isSub then [] else masterTypeSyns vns site
             ]
     return (dataDec, dispatchDec)
 
-
-mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
-mkMDS f rh sd = MkDispatchSettings
+mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
+mkMDS f rh = MkDispatchSettings
     { mdsRunHandler = rh
-    , mdsSubDispatcher = sd
+    , mdsSubDispatcher =
+        [|\parentRunner getSub toParent env -> yesodSubDispatch
+                                 YesodSubRunnerEnv
+                                    { ysreParentRunner = parentRunner
+                                    , ysreGetSub = getSub
+                                    , ysreToParentRoute = toParent
+                                    , ysreParentEnv = env
+                                    }
+                              |]
     , mdsGetPathInfo = [|W.pathInfo|]
     , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
     , mdsMethod = [|W.requestMethod|]
@@ -289,35 +196,15 @@ mkDispatchInstance :: Type                      -- ^ The master site type
                    -> [ResourceTree c]          -- ^ The resource
                    -> DecsQ
 mkDispatchInstance master cxt f res = do
-    clause' <- 
-        mkDispatchClause 
-            (mkMDS 
-                f 
-                [|yesodRunner|] 
-                [|\parentRunner getSub toParent env -> yesodSubDispatch
-                    YesodSubRunnerEnv
-                    { ysreParentRunner = parentRunner
-                    , ysreGetSub = getSub
-                    , ysreToParentRoute = toParent
-                    , ysreParentEnv = env
-                    }
-                |])
-            res
+    clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) 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|] 
-                [|subTopDispatch|]) 
-        res
+    clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
     inner <- newName "inner"
     let innerFun = FunD inner [clause']
     helper <- newName "helper"
@@ -329,26 +216,5 @@ 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,6 +1,5 @@
 {-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 module Yesod.Core.Json
     ( -- * Convert from a JSON value
       defaultLayoutJson
@@ -32,18 +31,15 @@ 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)
+import Yesod.Core.Types (reqAccept, HasHandlerData (..))
 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
@@ -101,7 +97,7 @@ provideJson = provideRep . return . J.toEncoding
 -- | Same as 'parseInsecureJsonBody'
 --
 -- @since 0.3.0
-parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
+parseJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env (J.Result a)
 parseJsonBody = parseInsecureJsonBody
 {-# DEPRECATED parseJsonBody "Use parseCheckJsonBody or parseInsecureJsonBody instead" #-}
 
@@ -111,7 +107,7 @@ parseJsonBody = parseInsecureJsonBody
 -- Note: This function is vulnerable to CSRF attacks.
 --
 -- @since 1.6.11
-parseInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
+parseInsecureJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env (J.Result a)
 parseInsecureJsonBody = do
     eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')
     return $ case eValue of
@@ -134,22 +130,22 @@ parseInsecureJsonBody = do
 -- body will no longer be available.
 --
 -- @since 0.3.0
-parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
+parseCheckJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env (J.Result a)
 parseCheckJsonBody = do
     mct <- lookupHeader "content-type"
-    case fmap contentTypeHeaderIsJson mct of
-        Just True -> parseInsecureJsonBody
+    case fmap (B8.takeWhile (/= ';')) mct of
+        Just "application/json" -> parseInsecureJsonBody
         _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct
 
 -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
 -- error.
-parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
+parseJsonBody_ :: (HasHandlerData env, J.FromJSON a) => RIO env a
 parseJsonBody_ = requireInsecureJsonBody
 {-# DEPRECATED parseJsonBody_ "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}
 
 -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
 -- error.
-requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a
+requireJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env a
 requireJsonBody = requireInsecureJsonBody
 {-# DEPRECATED requireJsonBody "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}
 
@@ -157,7 +153,7 @@ requireJsonBody = requireInsecureJsonBody
 -- error.
 --
 -- @since 1.6.11
-requireInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m a
+requireInsecureJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env a
 requireInsecureJsonBody = do
     ra <- parseInsecureJsonBody
     case ra of
@@ -166,7 +162,7 @@ requireInsecureJsonBody = do
 
 -- | Same as 'parseCheckJsonBody', but return an invalid args response on a parse
 -- error.
-requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a
+requireCheckJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env a
 requireCheckJsonBody = do
     ra <- parseCheckJsonBody
     case ra of
@@ -184,10 +180,10 @@ array = J.Array . V.fromList . map J.toJSON
 --     @application\/json@ (e.g. AJAX, see 'acceptsJSON').
 --
 --     2. 3xx otherwise, following the PRG pattern.
-jsonOrRedirect :: (MonadHandler m, J.ToJSON a)
-               => Route (HandlerSite m) -- ^ Redirect target
+jsonOrRedirect :: (HasHandlerData env, J.ToJSON a)
+               => Route (HandlerSite env) -- ^ Redirect target
                -> a            -- ^ Data to send via JSON
-               -> m J.Value
+               -> RIO env J.Value
 jsonOrRedirect = jsonOrRedirect' J.toJSON
 
 -- | jsonEncodingOrRedirect simplifies the scenario where a POST handler sends a different
@@ -198,17 +194,17 @@ jsonOrRedirect = jsonOrRedirect' J.toJSON
 --
 --     2. 3xx otherwise, following the PRG pattern.
 -- @since 1.4.21
-jsonEncodingOrRedirect :: (MonadHandler m, J.ToJSON a)
-            => Route (HandlerSite m) -- ^ Redirect target
+jsonEncodingOrRedirect :: (HasHandlerData env, J.ToJSON a)
+            => Route (HandlerSite env) -- ^ Redirect target
             -> a            -- ^ Data to send via JSON
-            -> m J.Encoding
+            -> RIO env J.Encoding
 jsonEncodingOrRedirect = jsonOrRedirect' J.toEncoding
 
-jsonOrRedirect' :: MonadHandler m
+jsonOrRedirect' :: HasHandlerData env
             => (a -> b)
-            -> Route (HandlerSite m) -- ^ Redirect target
+            -> Route (HandlerSite env) -- ^ Redirect target
             -> a            -- ^ Data to send via JSON
-            -> m b
+            -> RIO env b
 jsonOrRedirect' f r j = do
     q <- acceptsJson
     if q then return (f j)
@@ -216,17 +212,8 @@ jsonOrRedirect' f r j = do
 
 -- | Returns @True@ if the client prefers @application\/json@ as
 -- indicated by the @Accept@ HTTP header.
-acceptsJson :: MonadHandler m => m Bool
+acceptsJson :: HasHandlerData env => RIO env 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,62 +1,51 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+-- FIXME rename to Internal
 module Yesod.Core.Types where
 
-import Data.Aeson (ToJSON)
 import qualified Data.ByteString.Builder            as BB
-import           Control.Arrow                      (first)
-import           Control.Exception                  (Exception)
-import           Control.Monad                      (ap)
-import           Control.Monad.IO.Class             (MonadIO (liftIO))
-import           Control.Monad.Logger               (LogLevel, LogSource,
-                                                     MonadLogger (..))
-import           Control.Monad.Primitive            (PrimMonad (..))
-import           Control.Monad.Trans.Resource       (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)
-import           Data.ByteString                    (ByteString)
+import           Control.Monad.Trans.Resource       (ResourceT)
 import qualified Data.ByteString.Lazy               as L
 import           Data.CaseInsensitive               (CI)
-import           Data.Conduit                       (Flush, ConduitT)
-import           Data.IORef                         (IORef, modifyIORef')
-import           Data.Map                           (Map, unionWith)
-import qualified Data.Map                           as Map
+import           Conduit                            (Flush, ConduitT)
+import           RIO.Map                            (unionWith)
+import qualified RIO.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 Control.Monad.Logger (MonadLoggerIO (..))
-import UnliftIO (MonadUnliftIO (..), SomeException)
+
+import RIO
+import RIO.Orphans
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -132,7 +121,7 @@ data FileInfo = FileInfo
     }
 
 data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
-                | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)
+                | FileUploadDisk !(ResourceMap -> NWP.BackEnd FilePath)
                 | FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ()))
 
 -- | How to determine the root of the application for constructing URLs.
@@ -177,39 +166,73 @@ data RunHandlerEnv child site = RunHandlerEnv
     , rheSite     :: !site
     , rheChild    :: !child
     , rheUpload   :: !(RequestBodyLength -> FileUpload)
-    , rheLog      :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
+    , rheLogFunc  :: !LogFunc
     , rheOnError  :: !(ErrorResponse -> YesodApp)
       -- ^ How to respond when an error is thrown internally.
       --
       -- Since 1.2.0
     , rheMaxExpires :: !Text
-
-      -- | @since 1.6.24.0
-      --   catch function for rendering 500 pages on exceptions.
-      --   by default this is catch from unliftio (rethrows all async exceptions).
-    , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m =>  m a -> (SomeException -> m a) -> m a)
     }
+instance HasLogFunc (RunHandlerEnv child site) where
+  logFuncL = lens rheLogFunc (\x y -> x { rheLogFunc = y })
 
-data HandlerData child site = HandlerData
+data SubHandlerData child site = SubHandlerData
     { handlerRequest  :: !YesodRequest
     , handlerEnv      :: !(RunHandlerEnv child site)
     , handlerState    :: !(IORef GHState)
-    , handlerResource :: !InternalState
+    , handlerResource :: !ResourceMap
     }
 
+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
-    { yreLogger         :: !Logger
+    { yreLogFunc        :: !LogFunc
     , yreSite           :: !site
     , yreSessionBackend :: !(Maybe SessionBackend)
     , yreGen            :: !(IO Int)
-    -- ^ Generate a random number uniformly distributed in the full
-    -- range of 'Int'.
-    --
-    -- Note: Before 1.6.20, the default value generates pseudo-random
-    -- number in an unspecified range. The range size may not be a power
-    -- of 2. Since 1.6.20, the default value uses a secure entropy source
-    -- and generates in the full range of 'Int'.
+    -- ^ Generate a random number
     , yreGetMaxExpires  :: !(IO Text)
+    , yreCleanup        :: !(IORef ())
+    -- ^ Used to ensure some cleanup actions can be performed via
+    -- garbage collection.
     }
 
 data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv
@@ -227,10 +250,7 @@ type ParentRunner parent
 
 -- | A generic handler monad, which can have a different subsite and master
 -- site. We define a newtype for better error message.
-newtype HandlerFor site a = HandlerFor
-    { unHandlerFor :: HandlerData site site -> IO a
-    }
-    deriving Functor
+type HandlerFor site = RIO (HandlerData site)
 
 data GHState = GHState
     { ghsSession :: !SessionMap
@@ -243,30 +263,19 @@ 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 'HandlerFor' monad and template haskell code should hide it away.
+-- the 'HandlerT' monad and template haskell code should hide it away.
 type YesodApp = YesodRequest -> ResourceT IO YesodResponse
 
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. While this is simply a @WriterT@, we define a newtype for
 -- better error messages.
-newtype WidgetFor site a = WidgetFor
-    { unWidgetFor :: WidgetData site -> IO a
-    }
-    deriving Functor
+type WidgetFor site = RIO (WidgetData site)
 
 data WidgetData site = WidgetData
   { wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))
-  , wdHandler :: {-# UNPACK #-} !(HandlerData site site)
+  , wdHandler :: {-# UNPACK #-} !(HandlerData 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:
@@ -276,8 +285,10 @@ instance a ~ () => IsString (WidgetFor site a) where
     fromString = toWidget . toHtml . T.pack
       where toWidget x = tellWidget mempty { gwdBody = Body (const x) }
 
-tellWidget :: GWData (Route site) -> WidgetFor site ()
-tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d)
+tellWidget :: HasWidgetData env => GWData (Route (HandlerSite env)) -> RIO env ()
+tellWidget d = do
+  wd <- view widgetDataL
+  modifyIORef' (wdRef wd) (<> d)
 
 type RY master = Route master -> [(Text, Text)] -> Text
 
@@ -295,14 +306,13 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
 --
 -- > PageContent url -> HtmlUrl url
 data PageContent url = PageContent
-    { pageTitle       :: !Html
-    , pageDescription :: !(Maybe Text)
-    , pageHead        :: !(HtmlUrl url)
-    , pageBody        :: !(HtmlUrl url)
+    { pageTitle :: !Html
+    , pageHead  :: !(HtmlUrl url)
+    , pageBody  :: !(HtmlUrl url)
     }
 
-data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
-             | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())
+data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length.
+             | ContentSource !(ConduitT () (Flush Builder) (ResourceT IO) ())
              | ContentFile !FilePath !(Maybe FilePart)
              | ContentDontEvaluate !Content
 
@@ -316,20 +326,6 @@ 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.
 --
@@ -339,29 +335,12 @@ newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
 -- | Responses to indicate some form of an error occurred.
 data ErrorResponse =
       NotFound
-        -- ^ The requested resource was not found.
-        -- Examples of when this occurs include when an incorrect URL is used, or @yesod-persistent@'s 'get404' doesn't find a value.
-        -- HTTP status: 404.
     | InternalError !Text
-        -- ^ Some sort of unexpected exception.
-        -- If your application uses `throwIO` or `error` to throw an exception, this is the form it would take.
-        -- HTTP status: 500.
     | InvalidArgs ![Text]
-        -- ^ Indicates some sort of invalid or missing argument, like a missing query parameter or malformed JSON body.
-        -- Examples Yesod functions that send this include 'requireCheckJsonBody' and @Yesod.Auth.GoogleEmail2@.
-        -- HTTP status: 400.
     | NotAuthenticated
-        -- ^ Indicates the user is not logged in.
-        -- This is thrown when 'isAuthorized' returns 'AuthenticationRequired'.
-        -- HTTP code: 401.
     | PermissionDenied !Text
-        -- ^ Indicates the user doesn't have permission to access the requested resource.
-        -- This is thrown when 'isAuthorized' returns 'Unauthorized'.
-        -- HTTP code: 403.
     | BadMethod !H.Method
-        -- ^ Indicates the URL would have been valid if used with a different HTTP method (e.g. a GET was used, but only POST is handled.)
-        -- HTTP code: 405.
-    deriving (Show, Eq, Generic)
+    deriving (Show, Eq, Typeable, Generic)
 instance NFData ErrorResponse
 
 ----- header stuff
@@ -374,9 +353,6 @@ 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` ()
@@ -394,7 +370,6 @@ 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
@@ -410,7 +385,6 @@ 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
@@ -418,21 +392,18 @@ data GWData a = GWData
     , gwdHead        :: !(Head a)
     }
 instance Monoid (GWData a) where
-    mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty
-#if !(MIN_VERSION_base(4,11,0))
+    mempty = GWData mempty mempty mempty mempty mempty mempty mempty
     mappend = (<>)
-#endif
 instance Semigroup (GWData a) where
-    GWData a1 a2 a3 a4 a5 a6 a7 a8 <>
-      GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData
+    GWData a1 a2 a3 a4 a5 a6 a7 <>
+      GWData b1 b2 b3 b4 b5 b6 b7 = GWData
         (mappend a1 b1)
         (mappend a2 b2)
         (mappend a3 b3)
         (mappend a4 b4)
-        (mappend a5 b5)
-        (unionWith mappend a6 b6)
+        (unionWith mappend a5 b5)
+        (mappend a6 b6)
         (mappend a7 b7)
-        (mappend a8 b8)
 
 data HandlerContents =
       HCContent !H.Status !TypedContent
@@ -442,6 +413,7 @@ 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)
@@ -453,82 +425,9 @@ 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
 
@@ -550,48 +449,34 @@ 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
-newtype SubHandlerFor sub master a = SubHandlerFor
-    { unSubHandlerFor :: HandlerData sub master -> IO a
-    }
-    deriving Functor
+type SubHandlerFor sub master = RIO (SubHandlerData sub master)
 
-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 '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
 
--- | @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
+-- | 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

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 -- | This is designed to be used as
 --
 -- > import qualified Yesod.Core.Unsafe as Unsafe
@@ -5,21 +6,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)
-                     => (site -> Logger)
+                     => LogFunc
                      -> site
                      -> HandlerFor site a
                      -> m a
-fakeHandlerGetLogger getLogger app f =
-     runFakeHandler mempty getLogger app f
+fakeHandlerGetLogger logFunc app f =
+     runFakeHandler mempty logFunc app f
  >>= either (error . ("runFakeHandler issue: " `mappend`) . show)
             return

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

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

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE PatternGuards #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
 module Yesod.Routes.Parse
@@ -11,7 +12,6 @@ module Yesod.Routes.Parse
     , TypeTree (..)
     , dropBracket
     , nameToType
-    , isTvar
     ) where
 
 import Language.Haskell.TH.Syntax
@@ -36,15 +36,9 @@ 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
 
@@ -265,13 +259,8 @@ ttToType (TTApp x y) = ttToType x `AppT` ttToType y
 ttToType (TTList t) = ListT `AppT` ttToType t
 
 nameToType :: String -> Type
-nameToType t = if isTvar t
-               then VarT $ mkName t
-               else ConT $ mkName t
-
-isTvar :: String -> Bool
-isTvar (h:_) = isLower h
-isTvar _     = False
+nameToType t@(h:_) | isLower h = VarT $ mkName t
+nameToType t = ConT $ mkName t
 
 pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
 pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}
 module Yesod.Routes.TH.Dispatch
     ( MkDispatchSettings (..)
@@ -74,7 +73,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
     handlePiece (Static str) = return (LitP $ StringL str, Nothing)
     handlePiece (Dynamic _) = do
         x <- newName "dyn"
-        let pat = ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x])
+        let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])
         return (pat, Just $ VarE x)
 
     handlePieces :: [Piece a] -> Q ([Pat], [Exp])
@@ -87,7 +86,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
     mkPathPat final =
         foldr addPat final
       where
-        addPat x y = conPCompat '(:) [x, y]
+        addPat x y = ConP '(:) [x, y]
 
     go :: SDC -> ResourceTree a -> Q Clause
     go sdc (ResourceParent name _check pieces children) = do
@@ -125,11 +124,11 @@ mkDispatchClause MkDispatchSettings {..} resources = do
                 Methods multi methods -> do
                     (finalPat, mfinalE) <-
                         case multi of
-                            Nothing -> return (conPCompat '[] [], Nothing)
+                            Nothing -> return (ConP '[] [], Nothing)
                             Just _ -> do
                                 multiName <- newName "multi"
                                 let pat = ViewP (VarE 'fromPathMultiPiece)
-                                                (conPCompat 'Just [VarP multiName])
+                                                (ConP 'Just [VarP multiName])
                                 return (pat, Just $ VarE multiName)
 
                     let dynsMulti =
@@ -201,10 +200,3 @@ 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,20 +1,9 @@
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
-
+{-# LANGUAGE TemplateHaskell, CPP #-}
 module Yesod.Routes.TH.RenderRoute
     ( -- ** RenderRoute
       mkRenderRouteInstance
-    , mkRenderRouteInstanceOpts
     , mkRouteCons
-    , mkRouteConsOpts
     , mkRenderRouteClauses
-
-    , RouteOpts
-    , defaultOpts
-    , setEqDerived
-    , setShowDerived
-    , setReadDerived
     ) where
 
 import Yesod.Routes.TH.Types
@@ -27,67 +16,16 @@ 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 = 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 =
+mkRouteCons rttypes =
     mconcat <$> mapM mkRouteCon rttypes
   where
     mkRouteCon (ResourceLeaf res) =
         return ([con], [])
       where
         con = NormalC (mkName $ resourceName res)
-            $ map (notStrict,)
+            $ map (\x -> (notStrict, x))
             $ concat [singles, multi, sub]
         singles = concatMap toSingle $ resourcePieces res
         toSingle Static{} = []
@@ -101,17 +39,16 @@ mkRouteConsOpts opts rttypes =
                 _ -> []
 
     mkRouteCon (ResourceParent name _check pieces children) = do
-        (cons, decs) <- mkRouteConsOpts opts children
-        let conts = mapM conT $ instanceNamesFromOpts opts
+        (cons, decs) <- mkRouteCons children
 #if MIN_VERSION_template_haskell(2,12,0)
-        dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) conts
+        dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq])
 #else
-        dec <- DataD [] (mkName name) [] Nothing cons <$> conts
+        dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]
 #endif
         return ([con], dec : decs)
       where
         con = NormalC (mkName name)
-            $ map (notStrict,)
+            $ map (\x -> (notStrict, x))
             $ singles ++ [ConT $ mkName name]
 
         singles = concatMap toSingle pieces
@@ -130,7 +67,7 @@ mkRenderRouteClauses =
         let cnt = length $ filter isDynamic pieces
         dyns <- replicateM cnt $ newName "dyn"
         child <- newName "child"
-        let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child]
+        let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]
 
         pack' <- [|pack|]
         tsp <- [|toPathPiece|]
@@ -147,12 +84,7 @@ 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
-#if MIN_VERSION_template_haskell(2,16,0)
-                                                  $ map Just
-#endif
-                                                  [pieces', VarE b]
-                                                ) `AppE` (rr `AppE` VarE child)
+        let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)
 
         return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
 
@@ -163,7 +95,7 @@ mkRenderRouteClauses =
             case resourceDispatch res of
                 Subsite{} -> return <$> newName "sub"
                 _ -> return []
-        let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub
+        let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
 
         pack' <- [|pack|]
         tsp <- [|toPathPiece|]
@@ -187,20 +119,11 @@ 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
-#if MIN_VERSION_template_haskell(2,16,0)
-                                                            $ map Just
-#endif
-                                                            [pieces, VarE b]
-                                                          ) `AppE` (rr `AppE` VarE x)
+                    return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
                 _ -> do
                     colon <- [|(:)|]
                     let cons a b = InfixE (Just a) colon (Just b)
-                    return $ TupE
-#if MIN_VERSION_template_haskell(2,16,0)
-                      $ map Just
-#endif
-                      [foldr cons piecesMulti piecesSingle, ListE []]
+                    return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]
 
         return $ Clause [pat] (NormalB body) []
 
@@ -215,23 +138,10 @@ mkRenderRouteClauses =
 -- 'renderRoute' method.  This function uses both 'mkRouteCons' and
 -- 'mkRenderRouteClasses'.
 mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
-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
+mkRenderRouteInstance cxt typ ress = do
     cls <- mkRenderRouteClauses ress
-    (cons, decs) <- mkRouteConsOpts opts ress
-#if MIN_VERSION_template_haskell(2,15,0)
-    did <- DataInstD [] Nothing (AppT (ConT ''Route) typ) Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
-    let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
-#elif MIN_VERSION_template_haskell(2,12,0)
+    (cons, decs) <- mkRouteCons ress
+#if 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
@@ -248,17 +158,10 @@ mkRenderRouteInstanceOpts opts cxt typ ress = do
           clazzes'
         else
           []
-    clazzes' = instanceNamesFromOpts opts
+    clazzes' = [''Show, ''Eq, ''Read]
 
 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,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Routes.TH.RouteAttrs
@@ -27,11 +26,7 @@ goTree front (ResourceParent name _check pieces trees) =
     toIgnore = length $ filter isDynamic pieces
     isDynamic Dynamic{} = True
     isDynamic Static{} = False
-    front' = front . ConP (mkName name)
-#if MIN_VERSION_template_haskell(2,18,0)
-                          []
-#endif
-                   . ignored
+    front' = front . ConP (mkName name) . 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 DeriveLift #-}
+{-# LANGUAGE TemplateHaskell #-}
 -- | 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 (Lift, Show, Functor)
+    deriving (Show, Functor)
 
 resourceTreePieces :: ResourceTree typ -> [Piece typ]
 resourceTreePieces (ResourceLeaf r) = resourcePieces r
@@ -31,6 +31,10 @@ 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]
@@ -38,17 +42,24 @@ data Resource typ = Resource
     , resourceAttrs :: [String]
     , resourceCheck :: CheckOverlap
     }
-    deriving (Lift, Show, Functor)
+    deriving (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 (Lift, Show)
+    deriving 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
@@ -58,12 +69,17 @@ data Dispatch typ =
         { subsiteType :: typ
         , subsiteFunc :: String
         }
-    deriving (Lift, Show)
+    deriving 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.yesodroutes")
+                routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations")
             length routes @?= 3
 
     describe "overlap checking" $ do

yesod-core/test/YesodCoreTest.hs

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

yesod-core/test/YesodCoreTest/Breadcrumb.hs

@@ -1,58 +0,0 @@
-{-# 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,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE Rank2Types #-}
 module YesodCoreTest.Cache
     ( cacheTest
@@ -21,8 +22,10 @@ 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,37 +1,26 @@
 {-# 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, AsyncException(..))
-import           UnliftIO.Exception(finally)
+import Control.Exception (SomeException, try)
 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
 
@@ -56,10 +45,6 @@ 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
@@ -71,7 +56,7 @@ instance Yesod App where
 
 getHomeR :: Handler Html
 getHomeR = do
-    $logDebug "Testing logging"
+    logDebug "Testing logging"
     defaultLayout $ toWidget [hamlet|
 $doctype 5
 
@@ -126,23 +111,6 @@ 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
@@ -186,10 +154,6 @@ 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
@@ -327,50 +291,3 @@ 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

@@ -1,41 +0,0 @@
-{-# 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

@@ -1,54 +0,0 @@
-{-# 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 :: MonadHandler m => m T.Text
+getBarR :: Monad m => m T.Text
 getBarR = return $ T.pack "BarR"
 
-getBazR :: (MonadHandler m, Yesod (HandlerSite m)) => m Html
+getBazR :: (HasHandlerData env, Yesod (HandlerSite env)) => RIO env Html
 getBazR = liftHandler $ defaultLayout [whamlet|Used Default Layout|]
 
-getBinR :: (MonadHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html
+getBinR :: (HasHandlerData env, Yesod (HandlerSite env), SubHandlerSite env ~ Subsite) => RIO env Html
 getBinR = do
     routeToParent <- getRouteToParent
     liftHandler $ defaultLayout [whamlet|

yesod-core/test/YesodCoreTest/ParameterizedSite.hs

@@ -1,37 +0,0 @@
-{-# 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

@@ -1,27 +0,0 @@
-{-# 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

@@ -1,26 +0,0 @@
-{-# 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

@@ -1,28 +0,0 @@
-{-# 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

@@ -1,50 +0,0 @@
-{-# 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

@@ -1,20 +0,0 @@
-{-# 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 = toWaiAppPlain Y >>= runSession f
+runner f = toWaiApp 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.25.1
+version:         1.6.13
 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.10
+cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 extra-source-files:
@@ -17,17 +17,15 @@ extra-source-files:
   test/YesodCoreTest/JsLoaderSites/Bottom.hs
   test/en.msg
   test/test.hs
-  test/fixtures/routes_with_line_continuations.yesodroutes
+  test/fixtures/routes_with_line_continuations
   ChangeLog.md
   README.md
 
 library
-    default-language: Haskell2010
     hs-source-dirs: src
 
-    build-depends:   base                  >= 4.10     && < 5
+    build-depends:   base                  >= 4.11     && < 5
                    , aeson                 >= 1.0
-                   , attoparsec-aeson      >= 2.1
                    , auto-update
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.7.1
@@ -40,28 +38,27 @@ 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
-                   , primitive             >= 0.6
-                   , random                >= 1.0.0.2  && < 1.3
+                   , random                >= 1.0.0.2  && < 1.2
                    , 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.14
+                   , vector                >= 0.9      && < 0.13
                    , wai                   >= 3.2
                    , wai-extra             >= 3.0.7
+                   -- FIXME remove?
                    , wai-logger            >= 0.2
                    , warp                  >= 3.0.2
                    , word8
@@ -78,7 +75,6 @@ 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
@@ -100,12 +96,14 @@ 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
-    other-extensions:      TemplateHaskell
+    extensions:      TemplateHaskell
 
 test-suite test-routes
-    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: RouteSpec.hs
     hs-source-dirs: test, src
@@ -122,7 +120,7 @@ test-suite test-routes
                    Yesod.Routes.TH.Types
 
     -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
-    other-extensions:      TemplateHaskell
+    extensions:      TemplateHaskell
 
     build-depends: base
                  , hspec
@@ -135,7 +133,6 @@ test-suite test-routes
                  , HUnit
 
 test-suite tests
-    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: test.hs
     hs-source-dirs: test
@@ -147,7 +144,6 @@ test-suite tests
                    YesodCoreTest.Header
                    YesodCoreTest.Csrf
                    YesodCoreTest.ErrorHandling
-                   YesodCoreTest.ErrorHandling.CustomApp
                    YesodCoreTest.Exceptions
                    YesodCoreTest.InternalRequest
                    YesodCoreTest.JsLoader
@@ -157,13 +153,8 @@ 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
@@ -174,8 +165,6 @@ test-suite tests
                    YesodCoreTest.StubSslOnly
                    YesodCoreTest.StubStrictSameSite
                    YesodCoreTest.StubUnsecured
-                   YesodCoreTest.SubSub
-                   YesodCoreTest.SubSubData
                    YesodCoreTest.WaiSubsite
                    YesodCoreTest.Widget
                    YesodCoreTest.YesodTest
@@ -207,10 +196,9 @@ test-suite tests
                   , warp
                   , yesod-core
     ghc-options:     -Wall -threaded
-    other-extensions: TemplateHaskell
+    extensions: TemplateHaskell
 
 benchmark widgets
-    default-language: Haskell2010
     type: exitcode-stdio-1.0
     hs-source-dirs: bench
     build-depends:  base

yesod-eventsource/ChangeLog.md

@@ -1,7 +1,3 @@
-## 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 :: MonadHandler m => m EventSourcePolyfill
+prepareForEventSource :: HasHandlerData env => RIO env 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 'HandlerFor' action
+-- | Return a Server-Sent Event stream given a 'HandlerT' action
 -- that is repeatedly called.  A state is threaded for the action
--- so that it may avoid using @IORefs@.  The @HandlerFor@ action
+-- so that it may avoid using @IORefs@.  The @HandlerT@ 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,6 +1,5 @@
-cabal-version:   >= 1.10
 name:            yesod-eventsource
-version:         1.6.0.1
+version:         1.6.0
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa <felipe.lessa@gmail.com>
@@ -8,14 +7,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
-    default-language: Haskell2010
-    build-depends:   base                  >= 4.10     && < 5
+    build-depends:   base                  >= 4        && < 5
                    , blaze-builder
                    , conduit               >= 1.3
                    , transformers

yesod-form-multi/ChangeLog.md

@@ -1,30 +0,0 @@
-# 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

@@ -1,20 +0,0 @@
-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

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

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

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

@@ -1,517 +0,0 @@
-{-# 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

@@ -1,39 +0,0 @@
-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,45 +1,5 @@
 # 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 provides a set of basic form inputs such as text, number, time,
+This package provies 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,7 +32,6 @@ 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
@@ -141,7 +140,7 @@ data BootstrapFormLayout =
 -- | Render the given form using Bootstrap v3 conventions.
 --
 -- Since: yesod-form 1.3.8
-renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
+renderBootstrap3 :: BootstrapFormLayout -> FormRender site a
 renderBootstrap3 formLayout aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
@@ -155,7 +154,7 @@ renderBootstrap3 formLayout aform fragment = do
                 $case formLayout
                   $of BootstrapBasicForm
                     $if fvId view /= bootstrapSubmitId
-                      <label :Blaze.null (fvLabel view):.sr-only for=#{fvId view}>#{fvLabel view}
+                      <label for=#{fvId view}>#{fvLabel view}
                     ^{fvInput view}
                     ^{helpWidget view}
                   $of BootstrapInlineForm
@@ -165,7 +164,7 @@ renderBootstrap3 formLayout aform fragment = do
                     ^{helpWidget view}
                   $of BootstrapHorizontalForm labelOffset labelSize inputOffset inputSize
                     $if fvId view /= bootstrapSubmitId
-                      <label :Blaze.null (fvLabel view):.sr-only .control-label .#{toOffset labelOffset} .#{toColumn labelSize} for=#{fvId view}>#{fvLabel view}
+                      <label .control-label .#{toOffset labelOffset} .#{toColumn labelSize} for=#{fvId view}>#{fvLabel view}
                       <div .#{toOffset inputOffset} .#{toColumn inputSize}>
                         ^{fvInput view}
                         ^{helpWidget view}
@@ -224,8 +223,8 @@ instance IsString msg => IsString (BootstrapSubmit msg) where
 --
 -- Since: yesod-form 1.3.8
 bootstrapSubmit
-    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
-    => BootstrapSubmit msg -> AForm m ()
+    :: RenderMessage site msg
+    => BootstrapSubmit msg -> AForm site ()
 bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
 
 
@@ -235,8 +234,8 @@ bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
 --
 -- Since: yesod-form 1.3.8
 mbootstrapSubmit
-    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
-    => BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
+    :: RenderMessage site msg
+    => BootstrapSubmit msg -> MForm site (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,10 +46,8 @@ module Yesod.Form.Fields
     , selectFieldHelper
     , selectField
     , selectFieldList
-    , selectFieldListGrouped
     , radioField
     , radioFieldList
-    , withRadioField
     , checkboxesField
     , checkboxesFieldList
     , multiSelectField
@@ -57,25 +55,23 @@ 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(..), LocalTime (LocalTime))
+import Data.Time (Day, TimeOfDay(..))
 import qualified Text.Email.Validate as Email
 import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
@@ -87,7 +83,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, forM_)
+import Control.Monad (when, unless)
 import Data.Either (partitionEithers)
 import Data.Maybe (listToMaybe, fromMaybe)
 
@@ -99,8 +95,7 @@ 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
-                      , split, splitOn
+                      , intercalate, isPrefixOf, null, unpack, pack, splitOn
                       )
 import qualified Data.Text as T (drop, dropWhile)
 import qualified Data.Text.Read
@@ -121,16 +116,14 @@ 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 :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Field m i
+intField :: (Integral i, RenderMessage site FormMessage) => Field site i
 intField = Field
     { fieldParse = parseHelper $ \s ->
-        case Data.Text.Read.signed Data.Text.Read.decimal s of
+        case Data.Text.Read.signed Data.Text.Read.decimal s of -- FIXME it overflows
             Right (a, "") -> Right a
             _ -> Left $ MsgInvalidInteger s
 
@@ -145,7 +138,7 @@ $newline never
     showI x = show (fromIntegral x :: Integer)
 
 -- | Creates a input with @type="number"@ and @step=any@.
-doubleField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Double
+doubleField :: RenderMessage site FormMessage => Field site Double
 doubleField = Field
     { fieldParse = parseHelper $ \s ->
         case Data.Text.Read.double (prependZero s) of
@@ -163,7 +156,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 :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day
+dayField :: RenderMessage site FormMessage => Field site Day
 dayField = Field
     { fieldParse = parseHelper $ parseDate . unpack
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -175,28 +168,28 @@ $newline never
   where showVal = either id (pack . show)
 
 -- | An alias for 'timeFieldTypeTime'.
-timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
+timeField :: RenderMessage site FormMessage => Field site 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 :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
+-- Since 1.4.2
+timeFieldTypeTime :: RenderMessage site FormMessage => Field site 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 :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
+-- Since 1.4.2
+timeFieldTypeText :: RenderMessage site FormMessage => Field site TimeOfDay
 timeFieldTypeText = timeFieldOfType "text"
 
-timeFieldOfType :: Monad m => RenderMessage (HandlerSite m) FormMessage => Text -> Field m TimeOfDay
+timeFieldOfType :: RenderMessage site FormMessage => Text -> Field site TimeOfDay
 timeFieldOfType inputType = Field
     { fieldParse = parseHelper parseTime
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -213,7 +206,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 :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html
+htmlField :: RenderMessage site FormMessage => Field site Html
 htmlField = Field
     { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -225,7 +218,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.
@@ -249,7 +242,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 :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea
+textareaField :: RenderMessage site FormMessage => Field site Textarea
 textareaField = Field
     { fieldParse = parseHelper $ Right . Textarea
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -260,8 +253,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 :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage)
-            => Field m p
+hiddenField :: (PathPiece p, RenderMessage site FormMessage)
+            => Field site p
 hiddenField = Field
     { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece
     , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
@@ -272,7 +265,7 @@ $newline never
     }
 
 -- | Creates a input with @type="text"@.
-textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
+textField :: RenderMessage site FormMessage => Field site Text
 textField = Field
     { fieldParse = parseHelper $ Right
     , fieldView = \theId name attrs val isReq ->
@@ -283,7 +276,7 @@ $newline never
     , fieldEnctype = UrlEncoded
     }
 -- | Creates an input with @type="password"@.
-passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
+passwordField :: RenderMessage site FormMessage => Field site Text
 passwordField = Field
     { fieldParse = parseHelper $ Right
     , fieldView = \theId name attrs _ isReq -> toWidget [hamlet|
@@ -293,15 +286,10 @@ $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
-              . readMay . replace '/' '-'
+              . readMaybe . 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
@@ -309,7 +297,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 . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser
+parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMaybe . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser
 
 timeParser :: Parser TimeOfDay
 timeParser = do
@@ -341,7 +329,10 @@ timeParser = do
         x <- digit
         y <- (return Control.Applicative.<$> digit) <|> return []
         let xy = x : y
-        let i = read xy
+        let i =
+              case readMaybe xy of
+                Just i' -> i'
+                Nothing -> error $ "The impossible happened parsing: " ++ show xy
         if i < 0 || i >= 24
             then fail $ show $ MsgInvalidHour $ pack xy
             else return i
@@ -350,13 +341,16 @@ timeParser = do
         x <- digit
         y <- digit <|> fail (show $ msg $ pack [x])
         let xy = [x, y]
-        let i = read xy
+        let i =
+              case readMaybe xy of
+                Just i' -> i'
+                Nothing -> error $ "The impossible happened parsing: " ++ show 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 :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
+emailField :: RenderMessage site FormMessage => Field site Text
 emailField = Field
     { fieldParse = parseHelper $
         \s ->
@@ -372,8 +366,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 :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
+-- Since 1.3.7
+multiEmailField :: RenderMessage site FormMessage => Field site [Text]
 multiEmailField = Field
     { fieldParse = parseHelper $
         \s ->
@@ -397,7 +391,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 :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text
+searchField :: RenderMessage site FormMessage => AutoFocus -> Field site Text
 searchField autoFocus = Field
     { fieldParse = parseHelper Right
     , fieldView = \theId name attrs val isReq -> do
@@ -418,7 +412,7 @@ $newline never
     , fieldEnctype = UrlEncoded
     }
 -- | Creates an input with @type="url"@, validating the URL according to RFC3986.
-urlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
+urlField :: RenderMessage site FormMessage => Field site Text
 urlField = Field
     { fieldParse = parseHelper $ \s ->
         case parseURI $ unpack s of
@@ -434,23 +428,15 @@ 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 (HandlerFor site) a
+                -> Field site a
 selectFieldList = selectField . optionsPairs
 
--- | 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:
+-- | Creates a @\<select>@ tag 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 (HandlerFor site) a
+            -> Field site a
 selectField = selectFieldHelper
     (\theId name attrs inside -> [whamlet|
 $newline never
@@ -464,22 +450,19 @@ $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 (HandlerFor site) [a]
+                     -> Field site [a]
 multiSelectFieldList = multiSelectField . optionsPairs
 
 -- | Creates a @\<select>@ tag for selecting multiple options.
 multiSelectField :: Eq a
                  => HandlerFor site (OptionList a)
-                 -> Field (HandlerFor site) [a]
+                 -> Field site [a]
 multiSelectField ioptlist =
-    Field parse view UrlEncoded
+    Field parse view' UrlEncoded
   where
     parse [] _ = return $ Right Nothing
     parse optlist _ = do
@@ -488,7 +471,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|
@@ -503,18 +486,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 (HandlerFor site) a
+               -> Field site a
 radioFieldList = radioField . optionsPairs
 
 -- | Creates an input with @type="checkbox"@ for selecting multiple options.
 checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)]
-                     -> Field (HandlerFor site) [a]
+                     -> Field site [a]
 checkboxesFieldList = checkboxesField . optionsPairs
 
 -- | Creates an input with @type="checkbox"@ for selecting multiple options.
 checkboxesField :: Eq a
                  => HandlerFor site (OptionList a)
-                 -> Field (HandlerFor site) [a]
+                 -> Field site [a]
 checkboxesField ioptlist = (multiSelectField ioptlist)
     { fieldView =
         \theId name attrs val _isReq -> do
@@ -532,62 +515,35 @@ 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 (HandlerFor site) a
-radioField = withRadioField
-    (\theId optionWidget -> [whamlet|
+           -> Field site a
+radioField = selectFieldHelper
+    (\theId _name _attrs inside -> [whamlet|
 $newline never
-<div .radio>
-    <label for=#{theId}-none>
-        <div>
-            ^{optionWidget}
-            _{MsgSelectNone}
+<div ##{theId}>^{inside}
 |])
-    (\theId value _isSel text optionWidget -> [whamlet|
+    (\theId name isSel -> [whamlet|
 $newline never
-<div .radio>
-    <label for=#{theId}-#{value}>
-        <div>
-            ^{optionWidget}
-            \#{text}
+<label .radio for=#{theId}-none>
+    <div>
+        <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
+        _{MsgSelectNone}
 |])
-
-
--- | 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|
+    (\theId name attrs value isSel text -> [whamlet|
 $newline never
-<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}>
-|]
-
+<label .radio for=#{theId}-#{value}>
+    <div>
+        <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
+        \#{text}
+|])
 
 -- | Creates a group of radio buttons to answer the question given in the message. Radio buttons are used to allow differentiating between an empty response (@Nothing@) and a no response (@Just False@). Consider using the simpler 'checkBoxField' if you don't need to make this distinction.
 --
 -- If this field is optional, the first radio button is labeled "\<None>", the second \"Yes" and the third \"No".
 --
--- If this field is required, the first radio button is labeled \"Yes" and the second \"No".
+-- If this field is required, the first radio button is labeled \"Yes" and the second \"No". 
 --
 -- (Exact label titles will depend on localization).
-boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
+boolField :: RenderMessage site FormMessage => Field site Bool
 boolField = Field
       { fieldParse = \e _ -> return $ boolParser e
       , fieldView = \theId name attrs val isReq -> [whamlet|
@@ -618,7 +574,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
@@ -626,7 +582,7 @@ $newline never
 --
 --   Note that this makes the field always optional.
 --
-checkBoxField :: Monad m => Field m Bool
+checkBoxField :: Field site Bool
 checkBoxField = Field
     { fieldParse = \e _ -> return $ checkBoxParser e
     , fieldView  = \theId name attrs val _ -> [whamlet|
@@ -646,31 +602,15 @@ $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.
---
--- Extended by 'OptionListGrouped' in 1.7.0.
-data OptionList a
-  = OptionList
+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').
-    }
 
--- | 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
+-- | 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
@@ -679,63 +619,29 @@ 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 :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
-             => [(msg, a)] -> m (OptionList a)
+optionsPairs :: RenderMessage site msg => [(msg, a)] -> HandlerFor site (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 :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
+optionsEnum :: (Show a, Enum a, Bounded a) => HandlerFor site (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:
@@ -753,33 +659,22 @@ 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)
-               -> 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
+               -> RIO env (OptionList (Entity a))
 optionsPersist filts ords toDisplay = fmap mkOptionList $ do
     mr <- getMessageRender
-    pairs <- runDB $ selectList filts ords
+    pairs <- liftHandler $ runDB $ selectList filts ords
     return $ map (\(Entity key value) -> Option
         { optionDisplay = mr (toDisplay value)
         , optionInternalValue = Entity key value
@@ -789,36 +684,22 @@ 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
-#if MIN_VERSION_persistent(2,5,0)
+-- Since 1.3.2
 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)
-  -> 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
+  -> RIO env (OptionList (Key a))
+optionsPersistKey filts ords toDisplay = liftHandler $ fmap mkOptionList $ do
     mr <- getMessageRender
     pairs <- runDB $ selectList filts ords
     return $ map (\(Entity key value) -> Option
@@ -828,7 +709,7 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
         }) pairs
 
 -- |
--- A helper function for constucting 'selectField's with optional option groups. You may want to use this when you define your custom 'selectField's or 'radioField's.
+-- A helper function for constucting 'selectField's. You may want to use this when you define your custom 'selectField's or 'radioField's.
 --
 -- @since 1.6.2
 selectFieldHelper
@@ -836,26 +717,23 @@ selectFieldHelper
         => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()) -- ^ Outermost part of the field
         -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional
         -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options
-        -> (Maybe (Text -> WidgetFor site ())) -- ^ Group headers placed inbetween options
         -> HandlerFor site (OptionList a)
-        -> Field (HandlerFor site) a
-selectFieldHelper outside onOpt inside grpHdr opts' = Field
+        -> Field site a
+selectFieldHelper outside onOpt inside opts' = Field
     { fieldParse = \x _ -> do
-        opts <- fmap flattenOptionList opts'
+        opts <- opts'
         return $ selectParser opts x
     , fieldView = \theId name attrs val isReq -> do
+        opts <- fmap olOptions $ handlerToWidget opts'
         outside theId name attrs $ do
-          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
+            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)
     , fieldEnctype = UrlEncoded
     }
   where
@@ -868,18 +746,9 @@ selectFieldHelper outside onOpt inside grpHdr opts' = Field
             x -> case olReadExternal opts x of
                     Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
                     Just y -> Right $ Just y
-    constructOptions theId name attrs val isReq opts =
-      forM_ opts $ \opt -> inside
-                           theId
-                           name
-                           ((if isReq then (("required", "required"):) else id) attrs)
-                           (optionExternalValue opt)
-                           (render opts val == optionExternalValue opt)
-                           (optionDisplay opt)
 
 -- | Creates an input with @type="file"@.
-fileField :: Monad m
-          => Field m FileInfo
+fileField :: Field site FileInfo
 fileField = Field
     { fieldParse = \_ files -> return $
         case files of
@@ -891,18 +760,23 @@ fileField = Field
     , fieldEnctype = Multipart
     }
 
-fileAFormReq :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
-             => FieldSettings (HandlerSite m) -> AForm m FileInfo
-fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do
+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
     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 menvs of
+            case mfdParams mfd of
                 Nothing -> (FormMissing, Nothing)
                 Just (_, fenv) ->
                     case Map.lookup name fenv of
@@ -921,21 +795,26 @@ $newline never
             , fvErrors = errs
             , fvRequired = True
             }
-    return (res, (fv :), ints', Multipart)
+    writeIORef (mfdEnctype mfd) Multipart
+    pushBackDeque viewsDeque fv
+    return res
 
-fileAFormOpt :: MonadHandler m
-             => FieldSettings (HandlerSite m)
-             -> AForm m (Maybe FileInfo)
-fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
+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
     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 menvs of
+            case mfdParams mfd of
                 Nothing -> (FormMissing, Nothing)
                 Just (_, fenv) ->
                     case Map.lookup name fenv of
@@ -952,7 +831,9 @@ $newline never
             , fvErrors = errs
             , fvRequired = False
             }
-    return (res, (fv :), ints', Multipart)
+    writeIORef (mfdEnctype mfd) Multipart
+    pushBackDeque viewsDeque fv
+    return res
 
 incrInts :: Ints -> Ints
 incrInts (IntSingle i) = IntSingle $ i + 1
@@ -972,52 +853,11 @@ 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,3 +1,4 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -18,13 +19,10 @@ module Yesod.Form.Functions
     , wFormToMForm
       -- * Fields to Forms
     , wreq
-    , wreqMsg
     , wopt
     , mreq
-    , mreqMsg
     , mopt
     , areq
-    , areqMsg
     , aopt
       -- * Run a form
     , runFormPost
@@ -41,7 +39,6 @@ module Yesod.Form.Functions
     , renderTable
     , renderDivs
     , renderDivsNoLabels
-    , renderBootstrap
     , renderBootstrap2
       -- * Validation
     , check
@@ -58,13 +55,12 @@ 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)
@@ -78,8 +74,28 @@ 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 :: Monad m => MForm m Text
+newFormIdent :: MForm site Text
 newFormIdent = do
     i <- get
     let i' = incrInts i
@@ -89,60 +105,35 @@ newFormIdent = do
     incrInts (IntSingle i) = IntSingle $ i + 1
     incrInts (IntCons i is) = (i + 1) `IntCons` is
 
-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)
+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
 
-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)
+aFormToForm :: AForm site a
+            -> MForm site (FormResult a, [FieldView site] -> [FieldView site])
+aFormToForm (AForm wform) = do
+    (res, views) <- wFormToMForm wform
+    pure (res, (views++))
 
-askParams :: Monad m => MForm m (Maybe Env)
-askParams = do
-    (x, _, _) <- ask
-    return $ liftM fst x
+askParams :: MForm site (Maybe Env)
+askParams = view $ to (fmap fst . mfdParams)
 
-askFiles :: Monad m => MForm m (Maybe FileEnv)
-askFiles = do
-    (x, _, _) <- ask
-    return $ liftM snd x
+askFiles :: MForm site (Maybe FileEnv)
+askFiles = view $ to (fmap snd . mfdParams)
 
 -- | 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, HandlerSite m ~ site, MonadHandler m)
-     => Field m a           -- ^ form field
+wreq :: RenderMessage site FormMessage
+     => Field site a        -- ^ form field
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe a             -- ^ optional default value
-     -> 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
+     -> WForm site (FormResult a)
+wreq f fs = mFormToWForm . mreq f fs
 
 -- | 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
@@ -150,92 +141,78 @@ wreqMsg f fs msg = mFormToWForm . mreqMsg f fs msg
 -- value).
 --
 -- @since 1.4.14
-wopt :: (MonadHandler m, HandlerSite m ~ site)
-     => Field m a           -- ^ form field
+wopt :: Field site a        -- ^ form field
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe (Maybe a)     -- ^ optional default value
-     -> WForm m (FormResult (Maybe a))
+     -> WForm site (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 :: MonadHandler m
-             => WForm m (FormResult a)  -- ^ input form
-             -> AForm m a               -- ^ output form
+wFormToAForm
+  :: WForm site (FormResult a)  -- ^ input form
+  -> AForm site a               -- ^ output form
 wFormToAForm = formToAForm . wFormToMForm
 
 -- | Converts a monadic form 'WForm' into another monadic form 'MForm'.
 --
 -- @since 1.4.14
-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)
+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)
 
 -- | Converts a monadic form 'MForm' into another monadic form 'WForm'.
 --
 -- @since 1.4.14
-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])
+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
 
 -- | Converts a form field into monadic form. This field requires a value
 -- and will return 'FormFailure' if left empty.
-mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
-     => Field m a           -- ^ form field
+mreq :: RenderMessage site FormMessage
+     => Field site a         -- ^ form field
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe a             -- ^ optional default value
-     -> 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]
+     -> MForm site (FormResult a, FieldView site)
+mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
 
 -- | 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 :: (site ~ HandlerSite m, MonadHandler m)
-     => Field m a
+mopt :: Field site a
      -> FieldSettings site
      -> Maybe (Maybe a)
-     -> MForm m (FormResult (Maybe a), FieldView site)
+     -> MForm site (FormResult (Maybe a), FieldView site)
 mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
 
-mhelper :: (site ~ HandlerSite m, MonadHandler m)
-        => Field m a
+mhelper :: Field site a
         -> FieldSettings site
         -> Maybe a
         -> (site -> [Text] -> FormResult b) -- ^ on missing
         -> (a -> FormResult b) -- ^ on success
         -> Bool -- ^ is it required?
-        -> MForm m (FormResult b, FieldView site)
+        -> MForm site (FormResult b, FieldView site)
 
 mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
     tell fieldEnctype
     mp <- askParams
     name <- maybe newFormIdent return fsName
-    theId <- lift $ maybe newIdent return fsId
-    (_, site, langs) <- ask
+    theId <- maybe newIdent return fsId
+    site <- getYesod
+    langs <- reqLangs <$> getRequest
     let mr2 = renderMessage site langs
     (res, val) <-
         case mp of
@@ -244,7 +221,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 <- lift $ fieldParse mvals files
+                emx <- liftHandler $ fieldParse mvals files
                 return $ case emx of
                     Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals))
                     Right mx ->
@@ -264,44 +241,37 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
         })
 
 -- | Applicative equivalent of 'mreq'.
-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
+areq :: RenderMessage site FormMessage
+     => Field site a
+     -> FieldSettings site
+     -> Maybe a
+     -> AForm site a
+areq a b = formToAForm . liftM (second return) . mreq a b
 
 -- | Applicative equivalent of 'mopt'.
-aopt :: MonadHandler m
-     => Field m a
-     -> FieldSettings (HandlerSite m)
+aopt :: Field site a
+     -> FieldSettings site
      -> Maybe (Maybe a)
-     -> AForm m (Maybe a)
+     -> AForm site (Maybe a)
 aopt a b = formToAForm . liftM (second return) . mopt a b
 
-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)
+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
 
 -- | 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,
@@ -312,17 +282,19 @@ runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle
 -- 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 m) FormMessage, MonadResource m, MonadHandler m)
-            => (Html -> MForm m (FormResult a, xml))
-            -> m ((FormResult a, xml), Enctype)
+runFormPost
+  :: (RenderMessage (HandlerSite env) FormMessage, HasHandlerData env)
+  => (Html -> MForm (HandlerSite env) (FormResult a, xml))
+  -> RIO env ((FormResult a, xml), Enctype)
 runFormPost form = do
     env <- postEnv
     postHelper form env
 
-postHelper  :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
-            => (Html -> MForm m (FormResult a, xml))
-            -> Maybe (Env, FileEnv)
-            -> m ((FormResult a, xml), Enctype)
+postHelper
+  :: (HasHandlerData env, RenderMessage (HandlerSite env) FormMessage)
+  => (Html -> MForm (HandlerSite env) (FormResult a, xml))
+  -> Maybe (Env, FileEnv)
+  -> RIO env ((FormResult a, xml), Enctype)
 postHelper form env = do
     req <- getRequest
     let tokenKey = defaultCsrfParamName
@@ -330,15 +302,14 @@ postHelper form env = do
             case reqToken req of
                 Nothing -> Data.Monoid.mempty
                 Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|]
-    m <- getYesod
-    langs <- languages
-    ((res, xml), enctype) <- runFormGeneric (form token) m langs env
+    ((res, xml), enctype) <- runFormGeneric (form token) env
+    site <- getYesod
     let res' =
             case (res, env) of
                 (_, Nothing) -> FormMissing
                 (FormSuccess{}, Just (params, _))
                     | not (Map.lookup tokenKey params === reqToken req) ->
-                        FormFailure [renderMessage m langs MsgCsrfWarning]
+                        FormFailure [renderMessage site (reqLangs req) 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
@@ -351,12 +322,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 m) FormMessage, MonadHandler m)
-    => (Html -> MForm m (FormResult a, xml))
-    -> m (xml, Enctype)
+    :: (RenderMessage (HandlerSite env) FormMessage, HasHandlerData env)
+    => (Html -> MForm (HandlerSite env) (FormResult a, xml))
+    -> RIO env (xml, Enctype)
 generateFormPost form = first snd `liftM` postHelper form Nothing
 
-postEnv :: MonadHandler m => m (Maybe (Env, FileEnv))
+postEnv :: HasHandlerData env => RIO env (Maybe (Env, FileEnv))
 postEnv = do
     req <- getRequest
     if requestMethod (reqWaiRequest req) == "GET"
@@ -366,18 +337,16 @@ 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 :: MonadHandler m
-                   => (Html -> MForm m a)
-                   -> m (a, Enctype)
+runFormPostNoToken :: HasHandlerData env
+                   => (Html -> MForm (HandlerSite env) a)
+                   -> RIO env (a, Enctype)
 runFormPostNoToken form = do
-    langs <- languages
-    m <- getYesod
-    env <- postEnv
-    runFormGeneric (form mempty) m langs env
+    params <- postEnv
+    runFormGeneric (form mempty) params
 
-runFormGet :: MonadHandler m
-           => (Html -> MForm m a)
-           -> m (a, Enctype)
+runFormGet :: HasHandlerData env
+           => (Html -> MForm (HandlerSite env) a)
+           -> RIO env (a, Enctype)
 runFormGet form = do
     gets <- liftM reqGetParams getRequest
     let env =
@@ -391,29 +360,27 @@ runFormGet form = do
 --
 -- Since 1.3.11
 generateFormGet'
-    :: MonadHandler m
-    => (Html -> MForm m (FormResult a, xml))
-    -> m (xml, Enctype)
+    :: HasHandlerData env
+    => (Html -> MForm (HandlerSite env) (FormResult a, xml))
+    -> RIO env (xml, Enctype)
 generateFormGet' form = first snd `liftM` getHelper form Nothing
 
 {-# DEPRECATED generateFormGet "Will require RenderMessage in next version of Yesod" #-}
-generateFormGet :: MonadHandler m
-                => (Html -> MForm m a)
-                -> m (a, Enctype)
+generateFormGet :: HasHandlerData env
+                => (Html -> MForm (HandlerSite env) a)
+                -> RIO env (a, Enctype)
 generateFormGet form = getHelper form Nothing
 
 getKey :: Text
 getKey = "_hasdata"
 
-getHelper :: MonadHandler m
-          => (Html -> MForm m a)
+getHelper :: HasHandlerData env
+          => (Html -> MForm (HandlerSite env) a)
           -> Maybe (Env, FileEnv)
-          -> m (a, Enctype)
-getHelper form env = do
+          -> RIO env (a, Enctype)
+getHelper form params = do
     let fragment = [shamlet|<input type=hidden name=#{getKey}>|]
-    langs <- languages
-    m <- getYesod
-    runFormGeneric (form fragment) m langs env
+    runFormGeneric (form fragment) params
 
 
 -- | Creates a hidden field on the form that identifies it.  This
@@ -438,10 +405,9 @@ getHelper form env = do
 -- even if their number or order change between the HTML
 -- generation and the form submission.
 identifyForm
-  :: Monad m
-  => Text -- ^ Form identification string.
-  -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
-  -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
+  :: Text -- ^ Form identification string.
+  -> (Html -> MForm site (FormResult a, WidgetFor site ()))
+  -> (Html -> MForm site (FormResult a, WidgetFor site ()))
 identifyForm identVal form = \fragment -> do
     -- Create hidden <input>.
     let fragment' =
@@ -458,7 +424,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 (\(_, h, l) -> (Nothing, h, l))
+    let eraseParams | missing   = local (const Nothing)
                     | otherwise = id
     ( res', w) <- eraseParams (form fragment')
 
@@ -470,12 +436,12 @@ identifyFormKey :: Text
 identifyFormKey = "_formid"
 
 
-type FormRender m a =
-       AForm m a
+type FormRender site a =
+       AForm site a
     -> Html
-    -> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
+    -> MForm site (FormResult a, WidgetFor site ())
 
-renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
+renderTable, renderDivs, renderDivsNoLabels :: FormRender env 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.
@@ -509,7 +475,7 @@ renderDivs = renderDivsMaybeLabels True
 -- | render a field inside a div, not displaying any label
 renderDivsNoLabels = renderDivsMaybeLabels False
 
-renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a
+renderDivsMaybeLabels :: Bool -> FormRender env a
 renderDivsMaybeLabels withLabels aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
@@ -547,7 +513,7 @@ $forall view <- views
 -- >        <input .btn .primary type=submit value=_{MsgSubmit}>
 --
 -- Since 1.3.14
-renderBootstrap2 :: Monad m => FormRender m a
+renderBootstrap2 :: FormRender env a
 renderBootstrap2 aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
@@ -568,26 +534,21 @@ renderBootstrap2 aform fragment = do
                 |]
     return (res, widget)
 
--- | 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)
+check :: RenderMessage site msg
       => (a -> Either msg a)
-      -> Field m a
-      -> Field m a
+      -> Field site a
+      -> Field site a
 check f = checkM $ return . f
 
 -- | Return the given error message if the predicate is false.
-checkBool :: (Monad m, RenderMessage (HandlerSite m) msg)
-          => (a -> Bool) -> msg -> Field m a -> Field m a
+checkBool :: RenderMessage site msg
+          => (a -> Bool) -> msg -> Field site a -> Field site a
 checkBool b s = check $ \x -> if b x then Right x else Left s
 
-checkM :: (Monad m, RenderMessage (HandlerSite m) msg)
-       => (a -> m (Either msg a))
-       -> Field m a
-       -> Field m a
+checkM :: RenderMessage site msg
+       => (a -> HandlerFor site (Either msg a))
+       -> Field site a
+       -> Field site a
 checkM f = checkMMap f id
 
 -- | Same as 'checkM', but modifies the datatype.
@@ -596,11 +557,11 @@ checkM f = checkMMap f id
 -- the new datatype to the old one (the second argument to this function).
 --
 -- Since 1.1.2
-checkMMap :: (Monad m, RenderMessage (HandlerSite m) msg)
-          => (a -> m (Either msg b))
+checkMMap :: RenderMessage site msg
+          => (a -> HandlerFor site (Either msg b))
           -> (b -> a)
-          -> Field m a
-          -> Field m b
+          -> Field site a
+          -> Field site b
 checkMMap f inv field = field
     { fieldParse = \ts fs -> do
         e1 <- fieldParse field ts fs
@@ -612,7 +573,7 @@ checkMMap f inv field = field
     }
 
 -- | Allows you to overwrite the error message on parse error.
-customErrorMessage :: Monad m => SomeMessage (HandlerSite m) -> Field m a -> Field m a
+customErrorMessage :: SomeMessage site -> Field site a -> Field site a
 customErrorMessage msg field = field
     { fieldParse = \ts fs ->
         liftM (either (const $ Left msg) Right)
@@ -663,11 +624,10 @@ parseHelperGen f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $
 -- > lazyTextField = convertField TL.fromStrict TL.toStrict textField
 --
 -- Since 1.3.16
-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
+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
   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,5 +24,3 @@ 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,5 +24,3 @@ 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,5 +24,3 @@ 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,5 +24,3 @@ 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,5 +24,3 @@ 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,5 +24,3 @@ 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,5 +24,3 @@ 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,5 +24,3 @@ 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,5 +24,3 @@ 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,5 +24,3 @@ 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,5 +24,3 @@ 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

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