.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
@@ -25,5 +24,3 @@ tarballs/
 
 # OS X
 .DS_Store
-*.yaml.lock
-dist-newstyle/

.travis.yml

@@ -0,0 +1,185 @@
+# This is the complex Travis configuration, which is intended for use
+# on open source libraries which need compatibility across multiple GHC
+# versions, must work with cabal-install, and should be
+# cross-platform. For more information and other options, see:
+#
+# https://docs.haskellstack.org/en/stable/travis_ci/
+#
+# Copy these contents into the root directory of your Github project in a file
+# named .travis.yml
+
+# Use new container infrastructure to enable caching
+sudo: false
+
+# Do not choose a language; we provide our own build tools.
+language: generic
+
+# Caching so the next build will be fast too.
+cache:
+  directories:
+  - $HOME/.ghc
+  - $HOME/.cabal
+  - $HOME/.stack
+
+# The different configurations we want to test. We have BUILD=cabal which uses
+# cabal-install, and BUILD=stack which uses Stack. More documentation on each
+# of those below.
+#
+# We set the compiler values here to tell Travis to use a different
+# cache file per set of arguments.
+#
+# If you need to have different apt packages for each combination in the
+# matrix, you can use a line such as:
+#     addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}
+matrix:
+  include:
+  # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:
+  # https://github.com/hvr/multi-ghc-travis
+  - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
+    compiler: ": #GHC 8.0.2"
+    addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+  - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7
+    compiler: ": #GHC 8.2.2"
+    addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+  - env: BUILD=cabal GHCVER=8.4.3 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7
+    compiler: ": #GHC 8.4.3"
+    addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.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="--stack-yaml stack-lts-9.yaml --resolver lts-9"
+    compiler: ": #stack 8.0.2"
+    addons: {apt: {packages: [libgmp-dev]}}
+
+  - env: BUILD=stack ARGS="--stack-yaml stack-lts-11.yaml --resolver lts-11"
+    compiler: ": #stack 8.2.2"
+    addons: {apt: {packages: [libgmp-dev]}}
+
+  - env: BUILD=stack ARGS="--stack-yaml stack-persistent-2-9.yaml"
+    compiler: ": #stack/persistent 2.9"
+    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="--stack-yaml stack-lts-9.yaml --resolver lts-9"
+    compiler: ": #stack 8.0.2 osx"
+    os: osx
+
+  - env: BUILD=stack ARGS="--stack-yaml stack-lts-11.yaml --resolver lts-11"
+    compiler: ": #stack 8.2.2 osx"
+    os: osx
+
+  - env: BUILD=stack ARGS="--stack-yaml stack-persistent-2-9.yaml"
+    compiler: ": #stack/persistent 2.9"
+    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 --recursive http://github.com/yesodweb/shakespeare
-git clone --recurse-submodules http://github.com/yesodweb/persistent
+git clone --recursive http://github.com/yesodweb/persistent
-git clone --recurse-submodules http://github.com/yesodweb/wai
+git clone --recursive http://github.com/yesodweb/wai
-git clone --recurse-submodules http://github.com/yesodweb/yesod
+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.

sources.txt

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

stack-lts-11.yaml

@@ -0,0 +1 @@
+stack.yaml

stack-lts-9.yaml

@@ -0,0 +1,37 @@
+resolver: lts-9.21
+packages:
+- ./yesod-core
+- ./yesod-static
+- ./yesod-persistent
+- ./yesod-newsfeed
+- ./yesod-form
+- ./yesod-auth
+- ./yesod-auth-oauth
+- ./yesod-sitemap
+- ./yesod-test
+- ./yesod-bin
+- ./yesod
+- ./yesod-eventsource
+- ./yesod-websockets
+extra-deps:
+- bsb-http-chunked-0.0.0.2@rev:0
+- conduit-1.3.0.2@rev:0
+- conduit-extra-1.3.0@rev:0
+- html-conduit-1.3.0@rev:0
+- http-client-0.5.12.1@rev:0
+- http-conduit-2.3.1@rev:0
+- monad-logger-0.3.28.5@rev:0
+- mono-traversable-1.0.8.1@rev:0
+- persistent-2.8.2@rev:0
+- persistent-sqlite-2.8.1.2@rev:0
+- project-template-0.2.0.1@rev:0
+- resourcet-1.2.1@rev:0
+- streaming-commons-0.2.0.0@rev:0
+- typed-process-0.2.2.0@rev:0
+- unliftio-0.2.7.0@rev:0
+- unliftio-core-0.1.1.0@rev:0
+- wai-extra-3.0.22.1@rev:0
+- wai-logger-2.3.2@rev:0
+- warp-3.2.22@rev:0
+- xml-conduit-1.8.0@rev:0
+- yaml-0.8.30@rev:0

stack-persistent-2-9.yaml

@@ -0,0 +1,18 @@
+resolver: lts-11.10
+packages:
+- ./yesod-core
+- ./yesod-static
+- ./yesod-persistent
+- ./yesod-newsfeed
+- ./yesod-form
+- ./yesod-auth
+- ./yesod-auth-oauth
+- ./yesod-sitemap
+- ./yesod-test
+- ./yesod-bin
+- ./yesod
+- ./yesod-eventsource
+- ./yesod-websockets
+extra-deps:
+- persistent-2.9.0@rev:0
+- persistent-sqlite-2.9.0@rev:0

stack.yaml

@@ -1,11 +1,10 @@
-resolver: lts-18.3
+resolver: lts-11.10
 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,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
@@ -18,6 +18,7 @@ import           Control.Applicative      as A ((<$>), (<*>))
 import           Control.Arrow            ((***))
 import           UnliftIO.Exception
 import           Control.Monad.IO.Class
+import           UnliftIO                 (MonadUnliftIO)
 import           Data.ByteString          (ByteString)
 import           Data.Maybe
 import           Data.Text                (Text)
@@ -31,7 +32,7 @@ import           Yesod.Core
 
 data YesodOAuthException = CredentialError String Credential
                          | SessionError String
-                           deriving Show
+                           deriving (Show, Typeable)
 
 instance Exception YesodOAuthException
 
@@ -52,9 +53,14 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
     oauthSessionName = "__oauth_token_secret"
 
     dispatch
-      :: Text
+      :: ( MonadHandler m
+         , master ~ HandlerSite m
+         , Auth ~ SubHandlerSite m
+         , MonadUnliftIO m
+         )
+      => Text
       -> [Text]
-      -> AuthHandler master TypedContent
+      -> m TypedContent
     dispatch "GET" ["forward"] = do
         render <- getUrlRender
         tm <- getRouteToParent

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
+    if flag(ghc7)
-    build-depends:   authenticate-oauth      >= 1.5       && < 1.8
+        build-depends:   base                >= 4.3      && < 5
-                   , base                    >= 4.10      && < 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
                    , 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,66 +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/)
-
 ## 1.6.5
 
 * Add support for persistent 2.9 [#1516](https://github.com/yesodweb/yesod/pull/1516), [#1561](https://github.com/yesodweb/yesod/pull/1561)

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

@@ -8,6 +8,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Yesod.Auth
@@ -52,6 +53,7 @@ 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,7 +75,6 @@ import Control.Exception (Exception)
 import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
 import qualified Control.Monad.Trans.Writer    as Writer
 import Control.Monad (void)
-import Data.Kind (Type)
 
 type AuthRoute = Route Auth
 
@@ -420,20 +421,14 @@ authLayoutJson w json = selectRep $ do
 --
 -- @since 1.1.7
 clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
-           => Bool -- ^ if HTTP, redirect to 'logoutDest'
+           => Bool -- ^ if HTTP redirect to 'logoutDest' should be done
            -> m ()
 clearCreds doRedirects = do
+    y <- getYesod
     onLogout
     deleteSession credsKey
-    y  <- getYesod
+    when doRedirects $ do
-    aj <- acceptsJson
+        redirectUltDest $ logoutDest y
-    case (aj, doRedirects) of
-      (True, _)               -> sendResponse successfulLogout
-      (False, True)           -> redirectUltDest (logoutDest y)
-      _                       -> return ()
-    where successfulLogout = object ["message" .= msg]
-          msg :: Text
-          msg = "Logged out successfully!"
 
 getCheckR :: AuthHandler master TypedContent
 getCheckR = do
@@ -452,7 +447,7 @@ $nothing
     <p>Not logged in.
 |]
     jsonCreds creds =
-        toJSON $ Map.fromList
+        Object $ Map.fromList
             [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
             ]
 
@@ -514,6 +509,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,7 +529,7 @@ 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)
@@ -605,7 +601,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/Dummy.hs

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

yesod-auth/Yesod/Auth/Email.hs

@@ -113,21 +113,20 @@ module Yesod.Auth.Email
     , defaultRegisterHandler
     , defaultForgotPasswordHandler
     , defaultSetPasswordHandler
-     -- * Default helpers
-    , defaultRegisterHelper
     ) where
 
+import           Yesod.Auth
+import qualified Yesod.Auth.Message       as Msg
+import           Yesod.Core
+import           Yesod.Form
+import qualified Yesod.Auth.Util.PasswordStore as PS
 import           Control.Applicative      ((<$>), (<*>))
 import qualified Crypto.Hash              as H
 import qualified Crypto.Nonce             as Nonce
-import           Data.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 qualified Data.Text                as T
 import           Data.Text.Encoding       (decodeUtf8With, encodeUtf8)
 import qualified Data.Text.Encoding       as TE
 import           Data.Text.Encoding.Error (lenientDecode)
@@ -135,12 +134,9 @@ import           Data.Time                     (addUTCTime, getCurrentTime)
 import           Safe                     (readMay)
 import           System.IO.Unsafe         (unsafePerformIO)
 import qualified Text.Email.Validate
-import           Yesod.Auth
+import           Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
-import qualified Yesod.Auth.Message            as Msg
+import           Data.Maybe (isJust)
-import qualified Yesod.Auth.Util.PasswordStore as PS
+import Data.ByteArray (convert)
-import           Yesod.Core
-import           Yesod.Core.Types              (TypedContent (TypedContent))
-import           Yesod.Form
 
 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.
     --
@@ -401,40 +385,10 @@ 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
@@ -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>
@@ -562,12 +516,12 @@ parseRegister = withObject "email" (\obj -> do
                                       pass <- obj .:? "password"
                                       return (email, pass))
 
-defaultRegisterHelper :: YesodAuthEmail master
+registerHelper :: YesodAuthEmail master
-                      => Bool -- ^ Allow lookup via username in addition to email
+               => Bool -- ^ allow usernames?
-                      -> Bool -- ^ Set to `True` for forgot password flow, `False` for new account registration
+               -> Bool -- ^ forgot password?
                -> Route Auth
                -> AuthHandler master TypedContent
-defaultRegisterHelper allowUsername forgotPassword dest = do
+registerHelper allowUsername forgotPassword dest = do
     y <- getYesod
     checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
     result <- runInputPostResult $ (,)
@@ -595,7 +549,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                     _ -> Nothing
 
     case eidentifier of
-      Left failMsg -> loginErrorMessageI dest failMsg
+      Left route -> loginErrorMessageI dest route
       Right identifier -> do
             mecreds <- getEmailCreds identifier
             registerCreds <-
@@ -619,8 +573,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                 Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
                 Just creds@(_, False, _, _) -> sendConfirmationEmail creds
                 Just creds@(_, True, _, _) -> do
-                  if forgotPassword
+                  if forgotPassword then sendConfirmationEmail creds
-                    then sendConfirmationEmail creds
                     else case emailPreviouslyRegisteredResponse identifier of
                       Just response -> response
                       Nothing -> sendConfirmationEmail creds
@@ -628,14 +581,12 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                       render <- getUrlRender
                       tp <- getRouteToParent
                       let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey (isJust mpass)
-                      if forgotPassword
+                      sendVerifyEmail email verKey verUrl
-                         then sendForgotPasswordEmail email verKey verUrl
-                         else 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
@@ -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
+                    let msgAv = Msg.AddressVerified
-                                  then Msg.EmailVerified
-                                  else Msg.EmailVerifiedChangePass
                     selectRep $ do
                       provideRep $ do
                         addMessageI "success" msgAv
@@ -782,8 +731,8 @@ getPasswordR = do
     maid <- maybeAuthId
     case maid of
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-        Just aid -> do
+        Just _ -> do
-            needOld <- needOldPassword aid
+            needOld <- maybe (return True) needOldPassword maid
             setPasswordHandler needOld
 
 -- | Default implementation of 'setPasswordHandler'.

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -26,7 +26,6 @@
 --
 -- @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
@@ -53,20 +52,20 @@ module Yesod.Auth.GoogleEmail2
     , pid
     ) where
 
-import           Yesod.Auth                  (Auth, AuthHandler,
+import           Yesod.Auth               (Auth, AuthPlugin (AuthPlugin),
-                                              AuthPlugin (AuthPlugin),
                                            AuthRoute, Creds (Creds),
                                            Route (PluginR), YesodAuth,
-                                              logoutDest, runHttpRequest,
+                                           runHttpRequest, setCredsRedirect,
-                                              setCredsRedirect)
+                                           logoutDest, AuthHandler)
 import qualified Yesod.Auth.Message       as Msg
 import           Yesod.Core               (HandlerSite, MonadHandler,
-                                              TypedContent, addMessage,
+                                           TypedContent, getRouteToParent,
-                                              getRouteToParent, getUrlRender,
+                                           getUrlRender, invalidArgs,
-                                              getYesod, invalidArgs, liftIO,
+                                           liftIO, lookupGetParam,
-                                              liftSubHandler, lookupGetParam,
                                            lookupSession, notFound, redirect,
-                                              setSession, toHtml, whamlet, (.:))
+                                           setSession, whamlet, (.:),
+                                           addMessage, getYesod,
+                                           toHtml, liftSubHandler)
 
 
 import           Blaze.ByteString.Builder (fromByteString, toByteString)
@@ -87,6 +86,7 @@ import           Data.Aeson.Types            (FromJSON (parseJSON), parseEither,
                                            parseMaybe, withObject, withText)
 import           Data.Conduit
 import           Data.Conduit.Attoparsec  (sinkParser)
+import qualified Data.HashMap.Strict      as M
 import           Data.Maybe               (fromMaybe)
 import           Data.Monoid              (mappend)
 import           Data.Text                (Text)
@@ -102,13 +102,6 @@ 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
@@ -253,9 +246,7 @@ authPlugin storeToken clientID clientSecret =
         -- User's access token is saved for further access to API
         when storeToken $ setSession accessTokenKey accessToken'
 
-        personValReq <- personValueRequest token
+        personValue <- makeHttpRequest =<< personValueRequest token
-        personValue <- makeHttpRequest personValReq
-
         person <- case parseEither parseJSON personValue of
                 Left e -> error e
                 Right x -> return x
@@ -593,19 +584,9 @@ instance FromJSON EmailType where
         _         -> EmailType t
 
 allPersonInfo :: A.Value -> [(Text, Text)]
-allPersonInfo (A.Object o) = map enc $ mapToList o
+allPersonInfo (A.Object o) = map enc $ M.toList o
-  where
+    where enc (key, A.String s) = (key, s)
-    enc (key, A.String s) = (keyToText key, s)
+          enc (key, v) = (key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
-    enc (key, v) = (keyToText key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
-
-#if MIN_VERSION_aeson(2, 0, 0)
-    keyToText = Data.Aeson.Key.toText
-    mapToList = Data.Aeson.KeyMap.toList
-#else
-    keyToText = id
-    mapToList = M.toList
-#endif
-
 allPersonInfo _ = []
 
 

yesod-auth/Yesod/Auth/Hardcoded.hs

@@ -131,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,7 +159,6 @@ 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
     loginWidget toMaster = do

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 AddressVerified = "Address verified, please set a new password"
-englishMessage EmailVerifiedChangePass = "Email address verified, please set a new password"
-englishMessage EmailVerified = "Email address verified"
 englishMessage InvalidKeyTitle = "Invalid verification key"
 englishMessage InvalidKey = "I'm sorry, but that was an invalid verification key."
 englishMessage InvalidEmailPass = "Invalid email/password combination"
@@ -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 Email = "Email"
-germanMessage UserName = "Benutzername"
+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 NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben"
-germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter"
+germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter"
 germanMessage PasswordResetTitle = "Passwort zurücksetzen"
-germanMessage ProvideIdentifier = "E-Mail-Adresse oder Nutzername"
+germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"
-germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen"
+germanMessage SendPasswordResetEmail = "Email 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 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
+-- TODO
-germanMessage Logout = "Abmelden"
+germanMessage i@(IdentifierNotFound _) = englishMessage i
-germanMessage LogoutTitle = "Abmelden"
+germanMessage Logout = "Ausloggen" -- FIXME by Google Translate
-germanMessage AuthError = "Fehler beim Anmelden"
+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/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.cabal

@@ -1,6 +1,5 @@
-cabal-version:   >=1.10
 name:            yesod-auth
-version:         1.6.11.2
+version:         1.6.5
 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         && < 5
-    build-depends:   base                    >= 4.10      && < 5
                    , aeson                   >= 0.7
-                   , attoparsec-aeson        >= 2.1
                    , authenticate            >= 1.3.4
                    , base16-bytestring
                    , base64-bytestring
@@ -45,7 +43,7 @@ library
                    , http-types
                    , memory
                    , nonce                   >= 1.0.2     && < 1.1
-                   , persistent              >= 2.8
+                   , persistent              >= 2.8       && < 2.10
                    , random                  >= 1.0.0.2
                    , safe
                    , shakespeare
@@ -58,7 +56,7 @@ 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)

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)
+#if MIN_VERSION_Cabal(2, 2, 0)
-import Distribution.Simple.PackageDescription (readGenericPackageDescription)
-#elif MIN_VERSION_Cabal(2, 2, 0)
 import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
 #elif MIN_VERSION_Cabal(2, 0, 0)
 import Distribution.PackageDescription.Parse (readGenericPackageDescription)
 #else
 import Distribution.PackageDescription.Parse (readPackageDescription)
 #endif
-#if MIN_VERSION_Cabal(3, 6, 0)
-import Distribution.Utils.Path
-#endif
 import Distribution.PackageDescription.Configuration (flattenPackageDescription)
 import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)
 import Distribution.Verbosity (normal)
@@ -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 "config/routes" $ fixRoutes name pattern methods
-    modify routesPath $ 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
@@ -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")
+          let cert = $(embedFile "certificate.pem")
-              keyDef = $(embedFile "key.pem")
+              key = $(embedFile "key.pem")
-              theSettings = case cert opts of
+              tlsSettings = tlsSettingsMemory cert key
-                Nothing -> tlsSettingsMemory certDef keyDef
+          runTLS tlsSettings (setPort port defaultSettings') $ \req send -> do
-                Just (c,k) -> tlsSettings c k
-          runTLS theSettings (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)
+#if MIN_VERSION_Cabal(1, 20, 0)
-    cabal  <- D.tryFindPackageDesc D.silent "."
-#elif 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
+                       $ setDelegateCtlc True $ proc "stack" $
-                       $ 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

@@ -36,7 +36,6 @@ data Command = Init [String]
                      , 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,168 +1,5 @@
 # ChangeLog for yesod-core
 
-## 1.6.25.1
-
-* Export the options that were created in 1.6.25.0 [#1825](https://github.com/yesodweb/yesod/pull/1825)
-
-## 1.6.25.0
-
-* Add an options structure that allows the user to set which instances will be derived for a routes structure. [#1819](https://github.com/yesodweb/yesod/pull/1819)
-
-## 1.6.24.5
-
-* Support Aeson 2.2 [#1818](https://github.com/yesodweb/yesod/pull/1818)
-
-## 1.6.24.4
-
-* Fix test-suite compilation error for GHC >= 9.0.1 [#1812](https://github.com/yesodweb/yesod/pull/1812)
-
-## 1.6.24.3
-
-* Fix subsite-to-subsite dispatch [#1805](https://github.com/yesodweb/yesod/pull/1805)
-
-## 1.6.24.2
-
-* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
-
-## 1.6.24.1
-
-* Adapt to removal of `ListT` from transformers-0.6. [#1796](https://github.com/yesodweb/yesod/pull/1796)
-
-## 1.6.24.0
-
-* Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772).
-
-## 1.6.23.1
-
-* Fix typo in creation of the description `<meta>` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766)
-
-## 1.6.23
-
-* Add idempotent versions of `setDescription`, `setDescriptionI`. These functions
-  have odd behaviour when called multiple times, so they are now warned against.
-  This can't be a silent change - if you want to switch to the new functions, make
-  sure your layouts are updated to use `pageDescription` as well as `pageTitle`.
-  [#1765](https://github.com/yesodweb/yesod/pull/1765)
-
-## 1.6.22.1
-
-+ Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756)
-
-## 1.6.22.0
-
-* Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745)
-* Add instances for `ToContent Void`, `ToTypedContent Void`. [#1752](https://github.com/yesodweb/yesod/pull/1752)
-* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753)
-* Support template-haskell 2.18 [#1754](https://github.com/yesodweb/yesod/pull/1754)
-
-## 1.6.21.0
-
-* Export `Yesod.Core.Dispatch.defaultGen` so that users may reuse it for their own `YesodRunnerEnv`s [#1734](https://github.com/yesodweb/yesod/pull/1734)
-
-## 1.6.20.2
-
-* Fix compatibility with template-haskell 2.17 [#1729](https://github.com/yesodweb/yesod/pull/1729)
-
-## 1.6.20.1
-
-* Throw an error in `breadcrumbs` if the trail of breadcrumbs is circular. [#1727](https://github.com/yesodweb/yesod/issues/1727)
-
-## 1.6.20
-
-* Generate CSRF tokens using a secure entropy source [#1726](https://github.com/yesodweb/yesod/pull/1726)
-* Change semantics of `yreGen` and `defaultGen`
-
-## 1.6.19.0
-
-* Change order of priority in `languages`[#1721](https://github.com/yesodweb/yesod/pull/1721)
-
-## 1.6.18.8
-
-* Fix test suite for wai-extra change around vary header
-
-## 1.6.18.7
-
-* Fix functions generating Open Graph metadata[#1709](https://github.com/yesodweb/yesod/pull/1709)
-
-## 1.6.18.6
-
-* Update documentation from `HandlerT` to `HandlerFor` [#1703](https://github.com/yesodweb/yesod/pull/1703)
-
-## 1.6.18.5
-
-Document `ErrorResponse` [#1698](https://github.com/yesodweb/yesod/pull/1698)
-
-## 1.6.18.4
-
-* Fixed a bug where `mkYesod` and other TH functions didn't work for datatypes with explicitly stated type variables, including the case with typeclass constraints. [https://github.com/yesodweb/yesod/pull/1697](#1697)
-
-## 1.6.18.3
-
-* Remove mention of an oudated Yesod type (`GHandler`) from the docs for `handlerToIO`. [https://github.com/yesodweb/yesod/pull/1695](#1695)
-
-## 1.6.18.2
-
-* Recommends `.yesodroutes` as the file extension for Yesod routes files. [#1686](https://github.com/yesodweb/yesod/pull/1686)
-
-## 1.6.18.1
-
-* Increase the size of CSRF token
-
-## 1.6.18
-
-* Add functions for setting description and OG meta [#1663](https://github.com/yesodweb/yesod/pull/1663)
-
-* Use `DeriveLift` to implement the `Lift` instances for `ResourceTree`,
-  `Resource`, `Piece`, and `Dispatch`. Among other benefits, this provides
-  implementations of `liftTyped` on `template-haskell-2.16` (GHC 8.10) or
-  later. [#1664](https://github.com/yesodweb/yesod/pull/1664)
-
-## 1.6.17.3
-
-* Support for `unliftio-core` 0.2
-
-## 1.6.17.2
-
-* Support template-haskell 2.16, build with GHC 8.10 [#1657](https://github.com/yesodweb/yesod/pull/1657)
-
-## 1.6.17.1
-
-* Remove unnecessary deriving of Typeable
-
-## 1.6.17
-
-* Adds `contentTypeIsJson` [#1646](https://github.com/yesodweb/yesod/pull/1646)
-
-## 1.6.16.1
-
-* Compiles with GHC 8.8.1
-
-## 1.6.16
-
-* Add `jsAttributesHandler` to run arbitrary Handler code before building the
-  attributes map for the script tag generated by `widgetFile` [#1622](https://github.com/yesodweb/yesod/pull/1622)
-
-## 1.6.15
-
-* Move `redirectToPost` JavaScript form submission from HTML element to
-  `<script>` tag for CSP reasons [#1620](https://github.com/yesodweb/yesod/pull/1620)
-
-## 1.6.14
-
-* Introduce `JSONResponse`. [issue #1481](https://github.com/yesodweb/yesod/issues/1481) and [PR #1592](https://github.com/yesodweb/yesod/pull/1592)
-
-## 1.6.13
-
-* Introduce `maxContentLengthIO`. [issue #1588](https://github.com/yesodweb/yesod/issues/1588) and [PR #1589](https://github.com/yesodweb/yesod/pull/1589)
-
-## 1.6.12
-
-* Use at most one valid session cookie per request [#1581](https://github.com/yesodweb/yesod/pull/1581)
-
-## 1.6.11
-
-* Deprecate insecure JSON parsing functions [#1576](https://github.com/yesodweb/yesod/pull/1576)
-
 ## 1.6.10.1
 
 * Fix test suite compilation for [commercialhaskell/stackage#4319](https://github.com/commercialhaskell/stackage/issues/4319)

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

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

@@ -19,9 +19,7 @@ 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  )
@@ -78,9 +76,7 @@ instance MonadHandler (WidgetFor site) where
 #define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
 #define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
 GO(IdentityT)
-#if !MIN_VERSION_transformers(0,6,0)
 GO(ListT)
-#endif
 GO(MaybeT)
 GO(ExceptT e)
 GO(ReaderT r)
@@ -108,9 +104,7 @@ liftWidgetT = liftWidget
 #define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget
 #define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget
 GO(IdentityT)
-#if !MIN_VERSION_transformers(0,6,0)
 GO(ListT)
-#endif
 GO(MaybeT)
 GO(ExceptT e)
 GO(ReaderT r)

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

@@ -2,8 +2,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 module Yesod.Core.Class.Yesod where
 
 import           Yesod.Core.Content
@@ -25,7 +23,6 @@ import qualified Data.ByteString.Lazy               as L
 import Data.Aeson (object, (.=))
 import           Data.List                          (foldl', nub)
 import qualified Data.Map                           as Map
-import           Data.Maybe                         (catMaybes)
 import           Data.Monoid
 import           Data.Text                          (Text)
 import qualified Data.Text                          as T
@@ -54,10 +51,8 @@ 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 +69,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 +86,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
@@ -211,7 +194,6 @@ class RenderRoute site => Yesod site where
     addStaticContent _ _ _ = return Nothing
 
     -- | Maximum allowed length of the request body, in bytes.
-    -- This method may be ignored if 'maximumContentLengthIO' is overridden.
     --
     -- If @Nothing@, no maximum is applied.
     --
@@ -219,18 +201,6 @@ class RenderRoute site => Yesod site where
     maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64
     maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes
 
-    -- | Maximum allowed length of the request body, in bytes. This is similar
-    -- to 'maximumContentLength', but the result lives in @IO@. This allows
-    -- you to dynamically change the maximum file size based on some external
-    -- source like a database or an @IORef@.
-    --
-    -- The default implementation uses 'maximumContentLength'. Future version of yesod will
-    -- remove 'maximumContentLength' and use this method exclusively.
-    --
-    -- @since 1.6.13
-    maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)
-    maximumContentLengthIO a b = pure $ maximumContentLength a b
-
     -- | Creates a @Logger@ to use for log messages.
     --
     -- Note that a common technique (endorsed by the scaffolding) is to create
@@ -265,16 +235,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
@@ -546,18 +506,15 @@ defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddlew
 widgetToPageContent :: Yesod site
                     => WidgetFor site ()
                     -> HandlerFor site (PageContent (Route site))
-widgetToPageContent w = do
+widgetToPageContent w = HandlerFor $ \hd -> do
- jsAttrs <- jsAttributesHandler
- HandlerFor $ \hd -> do
   master <- unHandlerFor getYesod hd
   ref <- newIORef mempty
   unWidgetFor w WidgetData
     { wdRef = ref
     , wdHandler = hd
     }
-  GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref
+  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'
 
@@ -593,7 +550,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 +584,7 @@ widgetToPageContent w = do
             ^{regularScriptLoad}
         |]
 
-    return $ PageContent title description headAll $
+    return $ PageContent title headAll $
         case jsLoader master of
             BottomOfBody -> bodyScript
             _ -> body
@@ -656,7 +613,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 +637,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,7 +656,7 @@ 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
@@ -863,12 +820,6 @@ clientSessionBackend key getCachedDate =
     sbLoadSession = loadClientSession key getCachedDate "_SESSION"
   }
 
-justSingleton :: a -> [Maybe a] -> a
-justSingleton d = just . catMaybes
-  where
-    just [s] = s
-    just _   = d
-
 loadClientSession :: CS.Key
                   -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
                   -> S8.ByteString -- ^ session name
@@ -879,11 +830,11 @@ loadClientSession key getCachedDate sessionName req = load
     load = do
       date <- getCachedDate
       return (sess date, save date)
-    sess date = justSingleton Map.empty $ do
+    sess date = Map.unions $ do
       raw <- [v | (k, v) <- W.requestHeaders req, k == "Cookie"]
       val <- [v | (k, v) <- parseCookies raw, k == sessionName]
       let host = "" -- fixme, properly lock sessions to client address
-      return $ decodeClientSession key date host val
+      maybe [] return $ decodeClientSession key date host val
     save date sess' = do
       -- We should never cache the IV!  Be careful!
       iv <- liftIO CS.randomIV

yesod-core/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/Yesod/Core/Dispatch.hs

@@ -10,24 +10,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 (..)
@@ -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)
 
@@ -104,21 +92,8 @@ toWaiAppPlain site = do
             , yreGetMaxExpires = getMaxExpires
             }
 
--- | Generate a random number uniformly distributed in the full range
--- of 'Int'.
---
--- Note: Before 1.6.20, this generates pseudo-random number in an
--- unspecified range. The range size may not be a power of 2. Since
--- 1.6.20, this uses a secure entropy source and generates in the full
--- range of 'Int'.
---
--- @since 1.6.21.0
 defaultGen :: IO Int
-defaultGen = bsToInt <$> getEntropy bytes
+defaultGen = Random.getStdRandom Random.next
-  where
-    bits = finiteBitSize (undefined :: Int)
-    bytes = div (bits + 7) 8
-    bsToInt = S.foldl' (\v i -> shiftL v 8 .|. fromIntegral i) 0
 
 -- | Pure low level function to construct WAI application. Usefull
 -- when you need not standard way to run your app, or want to embed it
@@ -197,16 +172,6 @@ toWaiAppLogger logger site = do
 -- middlewares. This set may change at any point without a breaking version
 -- number. Currently, it includes:
 --
--- * Logging
---
--- * GZIP compression
---
--- * Automatic HEAD method handling
---
--- * Request method override with the _method query string parameter
---
--- * Accept header override with the _accept query string parameter
---
 -- If you need more fine-grained control of middlewares, please use 'toWaiApp'
 -- directly.
 --

yesod-core/Yesod/Core/Handler.hs

@@ -8,8 +8,8 @@
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TemplateHaskell            #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -91,8 +91,7 @@ module Yesod.Core.Handler
     , permissionDeniedI
     , invalidArgs
     , invalidArgsI
-      -- ** Short-circuit responses
+      -- ** Short-circuit responses.
-      -- $rollbackWarning
     , sendFile
     , sendFilePart
     , sendResponse
@@ -229,7 +228,7 @@ import qualified Data.ByteString.Lazy          as L
 import qualified Data.Map                      as Map
 import qualified Data.HashMap.Strict           as HM
 
-import           Data.ByteArray                (constEq)
+import           Data.Byteable                 (constEqBytes)
 
 import           Control.Arrow                 ((***))
 import qualified Data.ByteString.Char8         as S8
@@ -245,7 +244,6 @@ import           Text.Blaze.Html               (preEscapedToHtml, toHtml)
 import qualified Data.IORef                    as I
 import           Data.Maybe                    (listToMaybe, mapMaybe)
 import           Data.Typeable                 (Typeable)
-import           Data.Kind                     (Type)
 import           Web.PathPieces                (PathPiece(..))
 import           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
@@ -262,7 +260,7 @@ import qualified Data.Word8 as W8
 import qualified Data.Foldable as Fold
 import           Control.Monad.Logger (MonadLogger, logWarnS)
 
-type HandlerT site (m :: Type -> Type) = HandlerFor site
+type HandlerT site (m :: * -> *) = HandlerFor site
 {-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
 
 get :: MonadHandler m => m GHState
@@ -371,10 +369,10 @@ getPostParams = do
 getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
 getCurrentRoute = rheRoute <$> askHandlerEnv
 
--- | Returns a function that runs 'HandlerFor' actions inside @IO@.
+-- | Returns a function that runs 'HandlerT' actions inside @IO@.
 --
--- Sometimes you want to run an inner 'HandlerFor' action outside
+-- Sometimes you want to run an inner 'HandlerT' action outside
--- the control flow of an HTTP request (on the outer 'HandlerFor'
+-- the control flow of an HTTP request (on the outer 'HandlerT'
 -- action).  For example, you may want to spawn a new thread:
 --
 -- @
@@ -382,30 +380,30 @@ getCurrentRoute = rheRoute <$> askHandlerEnv
 -- getFooR = do
 --   runInnerHandler <- handlerToIO
 --   liftIO $ forkIO $ runInnerHandler $ do
---     /Code here runs inside HandlerFor but on a new thread./
+--     /Code here runs inside GHandler but on a new thread./
---     /This is the inner HandlerFor./
+--     /This is the inner GHandler./
 --     ...
 --   /Code here runs inside the request's control flow./
---   /This is the outer HandlerFor./
+--   /This is the outer GHandler./
 --   ...
 -- @
 --
 -- Another use case for this function is creating a stream of
--- server-sent events using 'HandlerFor' actions (see
+-- server-sent events using 'GHandler' actions (see
 -- @yesod-eventsource@).
 --
--- Most of the environment from the outer 'HandlerFor' is preserved
+-- Most of the environment from the outer 'GHandler' is preserved
--- on the inner 'HandlerFor', however:
+-- on the inner 'GHandler', however:
 --
 --  * The request body is cleared (otherwise it would be very
 --  difficult to prevent huge memory leaks).
 --
---  * The cache is cleared (see 'cached').
+--  * The cache is cleared (see 'CacheKey').
 --
--- Changes to the response made inside the inner 'HandlerFor' are
+-- Changes to the response made inside the inner 'GHandler' are
 -- ignored (e.g., session variables, cookies, response headers).
--- This allows the inner 'HandlerFor' to outlive the outer
+-- This allows the inner 'GHandler' to outlive the outer
--- 'HandlerFor' (e.g., on the @forkIO@ example above, a response
+-- 'GHandler' (e.g., on the @forkIO@ example above, a response
 -- may be sent to the client without killing the new thread).
 handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a)
 handlerToIO =
@@ -430,7 +428,7 @@ handlerToIO =
     -- xx From this point onwards, no references to oldHandlerData xx
     liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())
 
-    -- Return HandlerFor running function.
+    -- Return GHandler running function.
     return $ \(HandlerFor f) ->
       liftIO $
       runResourceT $ withInternalState $ \resState -> do
@@ -609,20 +607,6 @@ setMessageI = addMessageI ""
 getMessage :: MonadHandler m => m (Maybe Html)
 getMessage = fmap (fmap snd . listToMaybe) getMessages
 
--- $rollbackWarning
---
--- Note that since short-circuiting is implemented by using exceptions,
--- using e.g. 'sendStatusJSON' inside a runDB block
--- will result in the database actions getting rolled back:
---
--- @
--- runDB $ do
---   userId <- insert $ User "username" "email@example.com"
---   postId <- insert $ BlogPost "title" "hi there!"
---     /The previous two inserts will be rolled back./
---   sendStatusJSON Status.status200 ()
--- @
-
 -- | Bypass remaining handler code and output the given file.
 --
 -- For some backends, this is more efficient than reading in the file to
@@ -1038,7 +1022,7 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map k
 -- > redirect (NewsfeedR :#: storyId)
 --
 -- @since 1.2.9.
-data Fragment a b = a :#: b deriving Show
+data Fragment a b = a :#: b deriving (Show, Typeable)
 
 instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where
   toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a
@@ -1085,15 +1069,13 @@ $doctype 5
 <html>
     <head>
         <title>Redirecting...
-    <body>
+    <body onload="document.getElementById('form').submit()">
         <form id="form" method="post" action=#{urlText}>
             $maybe token <- reqToken req
                 <input type=hidden name=#{defaultCsrfParamName} value=#{token}>
             <noscript>
                 <p>Javascript has been disabled; please click on the button below to be redirected.
             <input type="submit" value="Continue">
-        <script>
-          window.onload = function() { document.getElementById('form').submit(); };
 |] >>= sendResponse
 
 -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
@@ -1227,10 +1209,10 @@ cacheBySet key value = do
 -- Languages are determined based on the following (in descending order
 -- of preference):
 --
--- * The _LANG get parameter.
---
 -- * The _LANG user session variable.
 --
+-- * The _LANG get parameter.
+--
 -- * The _LANG cookie.
 --
 -- * Accept-Language HTTP header.
@@ -1239,12 +1221,11 @@ cacheBySet key value = do
 -- If a matching language is not found the default language will be used.
 --
 -- This is handled by parseWaiRequest (not exposed).
---
--- __NOTE__: Before version @1.6.19.0@, this function prioritized the session
--- variable above all other sources.
---
 languages :: MonadHandler m => m [Text]
-languages = reqLangs <$> getRequest
+languages = do
+    mlang <- lookupSession langKey
+    langs <- reqLangs <$> getRequest
+    return $ maybe id (:) mlang langs
 
 lookup' :: Eq a => a -> [(a, b)] -> [b]
 lookup' a = map snd . filter (\x -> a == fst x)
@@ -1466,8 +1447,8 @@ respond ct = return . TypedContent ct . toContent
 
 -- | Use a @Source@ for the response body.
 --
--- Note that, for ease of use, the underlying monad is a @HandlerFor@. This
+-- Note that, for ease of use, the underlying monad is a @HandlerT@. This
--- implies that you can run any @HandlerFor@ action. However, since a streaming
+-- implies that you can run any @HandlerT@ action. However, since a streaming
 -- response occurs after the response headers have already been sent, some
 -- actions make no sense here. For example: short-circuit responses, setting
 -- headers, changing status codes, etc.
@@ -1478,8 +1459,8 @@ respondSource :: ContentType
               -> HandlerFor site TypedContent
 respondSource ctype src = HandlerFor $ \hd ->
     -- Note that this implementation relies on the fact that the ResourceT
-    -- environment provided by the server is the same one used in HandlerFor.
+    -- environment provided by the server is the same one used in HandlerT.
-    -- This is a safe assumption assuming the HandlerFor is run correctly.
+    -- This is a safe assumption assuming the HandlerT is run correctly.
     return $ TypedContent ctype $ ContentSource
            $ transPipe (lift . flip unHandlerFor hd) src
 
@@ -1667,8 +1648,8 @@ checkCsrfHeaderOrParam headerName paramName = do
     permissionDenied errorMessage
 
 validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool
--- It's important to use constant-time comparison (constEq) in order to avoid timing attacks.
+-- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.
-validCsrf (Just token) (Just param) = encodeUtf8 token `constEq` param
+validCsrf (Just token) (Just param) = encodeUtf8 token `constEqBytes` param
 validCsrf Nothing            _param = True
 validCsrf (Just _token)     Nothing = False
 

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

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

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

@@ -5,24 +5,9 @@
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TupleSections     #-}
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+module Yesod.Core.Internal.Run where
-module Yesod.Core.Internal.Run
+
-  ( toErrorHandler
-  , errFromShow
-  , basicRunHandler
-  , handleError
-  , handleContents
-  , evalFallback
-  , runHandler
-  , safeEh
-  , runFakeHandler
-  , yesodRunner
-  , yesodRender
-  , resolveApproot
-  )
-  where
 
-import qualified Control.Exception as EUnsafe
 import Yesod.Core.Internal.Response
 import           Data.ByteString.Builder      (toLazyByteString)
 import qualified Data.ByteString.Lazy         as BL
@@ -54,8 +39,6 @@ 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
@@ -88,7 +71,7 @@ basicRunHandler rhe handler yreq resState = do
 
     -- 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)
             tc <- evaluate (toTypedContent res)
@@ -189,19 +172,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 +192,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)
+    (finalSession, contents1) <- evalFallback contents0 (ghsSession state)
-    (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
+    (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
     contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
 
     -- Convert the HandlerContents into the final YesodResponse
@@ -236,27 +216,27 @@ 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.
+-- @HandlerT@'s return value.
-runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
+runFakeHandler :: (Yesod site, MonadIO m) =>
                   SessionMap
                -> (site -> Logger)
                -> site
@@ -277,7 +257,6 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
             , rheLog = messageLoggerSource site $ logger site
             , rheOnError = errHandler
             , rheMaxExpires = maxExpires
-            , rheCatchHandlerExceptions = catchHandlerExceptions site
             }
         handler'
       errHandler err req = do
@@ -319,16 +298,14 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
   _ <- runResourceT $ yapp fakeRequest
   I.readIORef ret
 
-yesodRunner :: forall res site . (ToTypedContent res, Yesod site)
+yesodRunner :: (ToTypedContent res, Yesod site)
             => HandlerFor site res
             -> YesodRunnerEnv site
             -> Maybe (Route site)
             -> Application
-yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
+yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
-  mmaxLen <- maximumContentLengthIO yreSite route
+  | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse (tooLargeResponse maxLen len)
-  case (mmaxLen, requestBodyLength req) of
+  | otherwise = do
-    (Just maxLen, KnownLength len) | maxLen < len -> sendResponse (tooLargeResponse maxLen len)
-    _ -> do
     let dontSaveSession _ = return []
     (session, saveSession) <- liftIO $
         maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend
@@ -354,7 +331,6 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
             , rheLog = log'
             , rheOnError = safeEh log'
             , rheMaxExpires = maxExpires
-              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite
             }
         rhe = rheSafe
             { rheOnError = runHandler rheSafe . errorHandler

yesod-core/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 where
-module Yesod.Core.Internal.TH
-    ( mkYesod
-    , mkYesodOpts
-
-    , mkYesodWith
-
-    , mkYesodData
-    , mkYesodDataOpts
-
-    , mkYesodSubData
-    , mkYesodSubDataOpts
-
-    , mkYesodWithParser
-    , mkYesodWithParserOpts
-
-    , mkYesodDispatch
-    , mkYesodDispatchOpts
-
-    , masterTypeSyns
-
-    , mkYesodGeneral
-    , mkYesodGeneralOpts
-
-    , mkMDS
-    , mkDispatchInstance
-
-    , mkYesodSubDispatch
-    
-    , subTopDispatch
-    , instanceD
-
-    , RouteOpts
-    , defaultOpts
-    , setEqDerived
-    , setShowDerived
-    , setReadDerived
-    )
- where
 
 import Prelude hiding (exp)
 import Yesod.Core.Handler
@@ -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 name = fmap (uncurry (++)) . mkYesodWithParser name False return
-
--- | `mkYesod` but with custom options.
---
--- @since 1.6.25.0
-mkYesodOpts :: RouteOpts
-            -> String
-            -> [ResourceTree String]
-            -> Q [Dec]
-mkYesodOpts opts name = fmap (uncurry (++)) . mkYesodWithParserOpts opts name False return
-
 
 {-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}
 -- | Similar to 'mkYesod', except contexts and type variables are not parsed. 
@@ -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 name resS = fst <$> mkYesodWithParser name False return resS
-
--- | `mkYesodData` but with custom options.
---
--- @since 1.6.25.0
-mkYesodDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
-mkYesodDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name False return resS
-
 
 mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodSubData = mkYesodSubDataOpts defaultOpts
+mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS
-
--- |
---
--- @since 1.6.25.0
-mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
-mkYesodSubDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name True return resS
-
 
 -- | Parses contexts and type arguments out of name before generating TH.
 mkYesodWithParser :: String                    -- ^ foundation type
@@ -128,22 +64,11 @@ mkYesodWithParser :: String                    -- ^ foundation type
                   -> (Exp -> Q Exp)            -- ^ unwrap handler
                   -> [ResourceTree String]
                   -> Q([Dec],[Dec])
-mkYesodWithParser = mkYesodWithParserOpts defaultOpts
+mkYesodWithParser name isSub f resS = do
-
--- | Parses contexts and type arguments out of name before generating TH.
---
--- @since 1.6.25.0
-mkYesodWithParserOpts :: RouteOpts                 -- ^ Additional route options
-                      -> String                    -- ^ foundation type
-                      -> Bool                      -- ^ is this a subsite
-                      -> (Exp -> Q Exp)            -- ^ unwrap handler
-                      -> [ResourceTree String]
-                      -> Q([Dec],[Dec])
-mkYesodWithParserOpts opts name isSub f resS = do
     let (name', rest, cxt) = case parse parseName "" name of
             Left err -> error $ show err
             Right a -> a
-    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
+mkYesodDispatch name = fmap snd . mkYesodWithParser name False return
-
--- | See 'mkYesodDataOpts'
---
--- @since 1.6.25.0
-mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
-mkYesodDispatchOpts opts name = fmap snd . mkYesodWithParserOpts opts name False return
-
 
 -- | Get the Handler and Widget type synonyms for the given site.
 masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself?
 masterTypeSyns vs site =
-    [ TySynD (mkName "Handler") (fmap plainTV vs)
+    [ TySynD (mkName "Handler") (fmap PlainTV vs)
       $ ConT ''HandlerFor `AppT` site
-    , TySynD (mkName "Widget")  (fmap plainTV vs)
+    , TySynD (mkName "Widget")  (fmap PlainTV vs)
       $ ConT ''WidgetFor `AppT` site `AppT` ConT ''()
     ]
 
-
 mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
                -> String                    -- ^ foundation type
                -> [String]                  -- ^ arguments for the type
@@ -204,20 +120,7 @@ mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in Ren
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral = mkYesodGeneralOpts defaultOpts
+mkYesodGeneral appCxt' namestr mtys isSub f resS = do
-
--- |
---
--- @since 1.6.25.0
-mkYesodGeneralOpts :: RouteOpts                 -- ^ Options to adjust route creation
-                   -> [[String]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
-                   -> String                    -- ^ foundation type
-                   -> [String]                  -- ^ arguments for the type
-                   -> Bool                      -- ^ is this a subsite
-                   -> (Exp -> Q Exp)            -- ^ unwrap handler
-                   -> [ResourceTree String]
-                   -> Q([Dec],[Dec])
-mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
     let appCxt = fmap (\(c:rest) -> 
             foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
           ) appCxt'
@@ -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 -> MkDispatchSettings a site b
-mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
+mkMDS f rh = MkDispatchSettings
-mkMDS f rh sd = 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' <- 
+    clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res
-        mkDispatchClause 
-            (mkMDS 
-                f 
-                [|yesodRunner|] 
-                [|\parentRunner getSub toParent env -> yesodSubDispatch
-                    YesodSubRunnerEnv
-                    { ysreParentRunner = parentRunner
-                    , ysreGetSub = getSub
-                    , ysreToParentRoute = toParent
-                    , ysreParentEnv = env
-                    }
-                |])
-            res
     let thisDispatch = FunD 'yesodDispatch [clause']
     return [instanceD cxt yDispatch [thisDispatch]]
   where
     yDispatch = ConT ''YesodDispatch `AppT` master
 
-
 mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
 mkYesodSubDispatch res = do
-    clause' <- 
+    clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
-        mkDispatchClause
-            (mkMDS 
-                return 
-                [|subHelper|] 
-                [|subTopDispatch|]) 
-        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/Yesod/Core/Json.hs

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleInstances          #-}
@@ -7,11 +8,8 @@
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
 module Yesod.Core.Types where
 
-import Data.Aeson (ToJSON)
 import qualified Data.ByteString.Builder            as BB
 import           Control.Arrow                      (first)
 import           Control.Exception                  (Exception)
@@ -37,6 +35,7 @@ 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
@@ -56,7 +55,7 @@ import           Control.Monad.Reader               (MonadReader (..))
 import Control.DeepSeq (NFData (rnf))
 import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
 import Control.Monad.Logger (MonadLoggerIO (..))
-import UnliftIO (MonadUnliftIO (..), SomeException)
+import UnliftIO (MonadUnliftIO (..), UnliftIO (..))
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -183,11 +182,6 @@ data RunHandlerEnv child site = RunHandlerEnv
       --
       -- Since 1.2.0
     , rheMaxExpires :: !Text
-
-      -- | @since 1.6.24.0
-      --   catch function for rendering 500 pages on exceptions.
-      --   by default this is catch from unliftio (rethrows all async exceptions).
-    , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m =>  m a -> (SomeException -> m a) -> m a)
     }
 
 data HandlerData child site = HandlerData
@@ -202,13 +196,7 @@ data YesodRunnerEnv site = YesodRunnerEnv
     , yreSite           :: !site
     , yreSessionBackend :: !(Maybe SessionBackend)
     , yreGen            :: !(IO Int)
-    -- ^ Generate a random number uniformly distributed in the full
+    -- ^ Generate a random number
-    -- range of 'Int'.
-    --
-    -- Note: Before 1.6.20, the default value generates pseudo-random
-    -- number in an unspecified range. The range size may not be a power
-    -- of 2. Since 1.6.20, the default value uses a secure entropy source
-    -- and generates in the full range of 'Int'.
     , yreGetMaxExpires  :: !(IO Text)
     }
 
@@ -243,7 +231,7 @@ data GHState = GHState
 
 -- | An extension of the basic WAI 'W.Application' datatype to provide extra
 -- features needed by Yesod. Users should never need to use this directly, as
--- the '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
@@ -296,7 +284,6 @@ 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)
     }
@@ -316,20 +303,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 +312,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.)
+    deriving (Show, Eq, Typeable, Generic)
-        -- HTTP code: 405.
-    deriving (Show, Eq, Generic)
 instance NFData ErrorResponse
 
 ----- header stuff
@@ -394,7 +350,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 +365,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 +372,20 @@ data GWData a = GWData
     , gwdHead        :: !(Head a)
     }
 instance Monoid (GWData a) where
-    mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty
+    mempty = GWData mempty mempty mempty mempty mempty mempty mempty
 #if !(MIN_VERSION_base(4,11,0))
     mappend = (<>)
 #endif
 instance Semigroup (GWData a) where
-    GWData a1 a2 a3 a4 a5 a6 a7 a8 <>
+    GWData a1 a2 a3 a4 a5 a6 a7 <>
-      GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData
+      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 a5 b5)
-        (unionWith mappend a6 b6)
+        (mappend a6 b6)
         (mappend a7 b7)
-        (mappend a8 b8)
 
 data HandlerContents =
       HCContent !H.Status !TypedContent
@@ -442,6 +395,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)
@@ -470,8 +424,9 @@ instance PrimMonad (WidgetFor site) where
     primitive = liftIO . primitive
 -- | @since 1.4.38
 instance MonadUnliftIO (WidgetFor site) where
-  {-# INLINE withRunInIO #-}
+  {-# INLINE askUnliftIO #-}
-  withRunInIO inner = WidgetFor $ \x -> inner $ flip unWidgetFor x
+  askUnliftIO = WidgetFor $ \wd ->
+                return (UnliftIO (flip unWidgetFor wd))
 instance MonadReader (WidgetData site) (WidgetFor site) where
     ask = WidgetFor return
     local f (WidgetFor g) = WidgetFor $ g . f
@@ -489,7 +444,7 @@ instance MonadLogger (WidgetFor site) where
 instance MonadLoggerIO (WidgetFor site) where
     askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
 
--- Instances for HandlerFor
+-- Instances for HandlerT
 instance Applicative (HandlerFor site) where
     pure = HandlerFor . const . return
     (<*>) = ap
@@ -508,8 +463,9 @@ instance MonadReader (HandlerData site site) (HandlerFor site) where
 
 -- | @since 1.4.38
 instance MonadUnliftIO (HandlerFor site) where
-  {-# INLINE withRunInIO #-}
+  {-# INLINE askUnliftIO #-}
-  withRunInIO inner = HandlerFor $ \x -> inner $ flip unHandlerFor x
+  askUnliftIO = HandlerFor $ \r ->
+                return (UnliftIO (flip unHandlerFor r))
 
 instance MonadThrow (HandlerFor site) where
     throwM = liftIO . throwM
@@ -580,8 +536,9 @@ instance MonadReader (HandlerData child master) (SubHandlerFor child master) whe
 
 -- | @since 1.4.38
 instance MonadUnliftIO (SubHandlerFor child master) where
-  {-# INLINE withRunInIO #-}
+  {-# INLINE askUnliftIO #-}
-  withRunInIO inner = SubHandlerFor $ \x -> inner $ flip unSubHandlerFor x
+  askUnliftIO = SubHandlerFor $ \r ->
+                return (UnliftIO (flip unSubHandlerFor r))
 
 instance MonadThrow (SubHandlerFor child master) where
     throwM = liftIO . throwM

yesod-core/Yesod/Core/Widget.hs

@@ -8,8 +8,6 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# 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 +29,6 @@ module Yesod.Core.Widget
       -- ** Head of page
     , setTitle
     , setTitleI
-    , setDescription
-    , setDescriptionI
-    , setDescriptionIdemp
-    , setDescriptionIdempI
-    , setOGType
-    , setOGImage
       -- ** CSS
     , addStylesheet
     , addStylesheetAttrs
@@ -66,7 +58,6 @@ import Yesod.Routes.Class
 import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
 import Text.Shakespeare.I18N (RenderMessage)
 import Data.Text (Text)
-import Data.Kind (Type)
 import qualified Data.Map as Map
 import Language.Haskell.TH.Quote (QuasiQuoter)
 import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
@@ -80,7 +71,7 @@ import qualified Data.Text.Lazy.Builder as TB
 import Yesod.Core.Types
 import Yesod.Core.Class.Handler
 
-type WidgetT site (m :: Type -> Type) = WidgetFor site
+type WidgetT site (m :: * -> *) = WidgetFor site
 {-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
 
 preEscapedLazyText :: TL.Text -> Html
@@ -90,19 +81,19 @@ class ToWidget site a where
     toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
 
 instance render ~ RY site => ToWidget site (render -> Html) where
-    toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty 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
@@ -133,9 +124,9 @@ instance render ~ RY site => ToWidgetMedia site (render -> Css) where
 instance ToWidgetMedia site Css where
     toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x
 instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
-    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty 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 ()
@@ -153,7 +144,7 @@ class ToWidgetHead site a where
     toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
 
 instance render ~ RY site => ToWidgetHead site (render -> Html) where
-    toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty 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,133 +160,18 @@ instance ToWidgetHead site Javascript where
 instance ToWidgetHead site Html where
     toWidgetHead = toWidgetHead . const
 
--- | Set the page title.
+-- | Set the page title. Calling 'setTitle' multiple times overrides previously
---
+-- set values.
--- Calling @setTitle@ or @setTitleI@ multiple times overrides previously set
--- values.
---
--- SEO Notes:
---
---    * Title tags are the second most important on-page factor for SEO, after
---      content
---    * Every page should have a unique title tag
---    * Start your title tag with your main targeted keyword
---    * Don't stuff your keywords
---    * Google typically shows 55-64 characters, so aim to keep your title
---      length under 60 characters
 setTitle :: MonadWidget m => Html -> m ()
-setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty
+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
 
--- | Set the localised page title.
+-- | Set the page title. Calling 'setTitle' multiple times overrides previously
---
+-- set values.
--- n.b. See comments for @setTitle@
 setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
 setTitleI msg = do
     mr <- getMessageRender
     setTitle $ toHtml $ mr msg
 
--- | Add description meta tag to the head of the page
---
--- Google does not use the description tag as a ranking signal, but the
--- contents of this tag will likely affect your click-through rate since it
--- shows up in search results.
---
--- The average length of the description shown in Google's search results is
--- about 160 characters on desktop, and about 130 characters on mobile, at time
--- of writing.
---
--- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
---
--- @since 1.6.18
-setDescription :: MonadWidget m => Text -> m ()
-setDescription description =
-    toWidgetHead $ [hamlet|<meta name=description content=#{description}>|]
-
-{-# WARNING setDescription
-  [ "setDescription is not idempotent; we recommend setDescriptionIdemp instead"
-  , "Multiple calls to setDescription will insert multiple meta tags in the page head."
-  , "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \
-    \may need to change your layout to include pageDescription."
-  ]
-#-}
-
--- | Add translated description meta tag to the head of the page
---
--- n.b. See comments for @setDescription@.
---
--- @since 1.6.18
-setDescriptionI
-  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)
-  => msg -> m ()
-setDescriptionI msg = do
-    mr <- getMessageRender
-    toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|]
-
-{-# WARNING setDescriptionI
-  [ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead"
-  , "Multiple calls to setDescriptionI will insert multiple meta tags in the page head."
-  , "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \
-    \may need to change your layout to include pageDescription."
-  ]
-#-}
-
--- | Add description meta tag to the head of the page
---
--- Google does not use the description tag as a ranking signal, but the
--- contents of this tag will likely affect your click-through rate since it
--- shows up in search results.
---
--- The average length of the description shown in Google's search results is
--- about 160 characters on desktop, and about 130 characters on mobile, at time
--- of writing.
---
--- Unlike 'setDescription', this version is *idempotent* - calling it multiple
--- times will result in only a single description meta tag in the head.
---
--- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
---
--- @since 1.6.23
-setDescriptionIdemp :: MonadWidget m => Text -> m ()
-setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty
-
--- | Add translated description meta tag to the head of the page
---
--- n.b. See comments for @setDescriptionIdemp@.
---
--- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple
--- times will result in only a single description meta tag in the head.
---
--- @since 1.6.23
-setDescriptionIdempI
-  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)
-  => msg -> m ()
-setDescriptionIdempI msg = do
-    mr <- getMessageRender
-    setDescriptionIdemp $ mr msg
-
--- | Add OpenGraph type meta tag to the head of the page
---
--- See all available OG types here: https://ogp.me/#types
---
--- @since 1.6.18
-setOGType :: MonadWidget m => Text -> m ()
-setOGType a = toWidgetHead $ [hamlet|<meta property="og:type" content=#{a}>|]
-
--- | Add OpenGraph image meta tag to the head of the page
---
--- Best practices:
---
---    * Use custom images for shareable pages, e.g., homepage, articles, etc.
---    * Use your logo or any other branded image for the rest of your pages.
---    * Use images with a 1.91:1 ratio and minimum recommended dimensions of
---      1200x630 for optimal clarity across all devices.
---
--- Source: https://ahrefs.com/blog/open-graph-meta-tags/
---
--- @since 1.6.18
-setOGImage :: MonadWidget m => Text -> m ()
-setOGImage a = toWidgetHead $ [hamlet|<meta property="og:image" content=#{a}>|]
-
 -- | Link to the specified local stylesheet.
 addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
 addStylesheet = flip addStylesheetAttrs []
@@ -305,7 +181,7 @@ addStylesheetAttrs :: MonadWidget m
                    => Route (HandlerSite m)
                    -> [(Text, Text)]
                    -> m ()
-addStylesheetAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
+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 ()
@@ -313,7 +189,7 @@ addStylesheetRemote = flip addStylesheetRemoteAttrs []
 
 -- | Link to the specified remote stylesheet.
 addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
-addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
+addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
 
 addStylesheetEither :: MonadWidget m
                     => Either (Route (HandlerSite m)) Text
@@ -331,7 +207,7 @@ addScript = flip addScriptAttrs []
 
 -- | Link to the specified local script.
 addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()
-addScriptAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
+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 ()
@@ -339,7 +215,7 @@ 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 x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
 
 whamlet :: QuasiQuoter
 whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings

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

yesod-core/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/Yesod/Routes/TH/RenderRoute.hs

@@ -1,20 +1,9 @@
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TemplateHaskell, CPP #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
-
 module Yesod.Routes.TH.RenderRoute
     ( -- ** RenderRoute
       mkRenderRouteInstance
-    , mkRenderRouteInstanceOpts
     , mkRouteCons
-    , mkRouteConsOpts
     , mkRenderRouteClauses
-
-    , RouteOpts
-    , defaultOpts
-    , setEqDerived
-    , setShowDerived
-    , setReadDerived
     ) where
 
 import Yesod.Routes.TH.Types
@@ -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
+mkRouteCons rttypes =
-
--- | Generate the constructors of a route data type, with custom opts.
---
--- @since 1.6.25.0
-mkRouteConsOpts :: RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])
-mkRouteConsOpts opts rttypes =
     mconcat <$> mapM mkRouteCon rttypes
   where
     mkRouteCon (ResourceLeaf res) =
         return ([con], [])
       where
         con = NormalC (mkName $ resourceName res)
-            $ map (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
+        (cons, decs) <- mkRouteCons children
-        let conts = mapM conT $ instanceNamesFromOpts opts
 #if MIN_VERSION_template_haskell(2,12,0)
-        dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) 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
+        let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)
-#if MIN_VERSION_template_haskell(2,16,0)
-                                                  $ map Just
-#endif
-                                                  [pieces', VarE b]
-                                                ) `AppE` (rr `AppE` VarE child)
 
         return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
 
@@ -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
+                    return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
-#if MIN_VERSION_template_haskell(2,16,0)
-                                                            $ map Just
-#endif
-                                                            [pieces, VarE b]
-                                                          ) `AppE` (rr `AppE` VarE x)
                 _ -> do
                     colon <- [|(:)|]
                     let cons a b = InfixE (Just a) colon (Just b)
-                    return $ TupE
+                    return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]
-#if MIN_VERSION_template_haskell(2,16,0)
-                      $ map Just
-#endif
-                      [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
+mkRenderRouteInstance cxt typ ress = do
-
--- | Generate the 'RenderRoute' instance.
---
--- This includes both the 'Route' associated type and the
--- 'renderRoute' method.  This function uses both 'mkRouteCons' and
--- 'mkRenderRouteClasses'.
---
--- @since 1.6.25.0
-mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
-mkRenderRouteInstanceOpts opts cxt typ ress = do
     cls <- mkRenderRouteClauses ress
-    (cons, decs) <- mkRouteConsOpts opts ress
+    (cons, decs) <- mkRouteCons ress
-#if MIN_VERSION_template_haskell(2,15,0)
+#if MIN_VERSION_template_haskell(2,12,0)
-    did <- DataInstD [] Nothing (AppT (ConT ''Route) typ) Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
-    let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
-#elif MIN_VERSION_template_haskell(2,12,0)
     did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
     let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
 #else
@@ -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/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)
+    front' = front . ConP (mkName name) . ignored
-#if MIN_VERSION_template_haskell(2,18,0)
-                          []
-#endif
-                   . ignored
 
 goRes :: (Pat -> Pat) -> Resource a -> Q Clause
 goRes front Resource {..} =

yesod-core/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 Control.Exception (SomeException, try)
-import           UnliftIO.Exception(finally)
 import Network.HTTP.Types (Status, mkStatus)
 import Data.ByteString.Builder (Builder, toLazyByteString)
 import Data.Monoid (mconcat)
 import Data.Text (Text, pack)
 import Control.Monad (forM_)
-import qualified Network.Wai.Handler.Warp as Warp
-import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom
 import Control.Monad.Trans.State (StateT (..))
 import Control.Monad.Trans.Reader (ReaderT (..))
 import qualified UnliftIO.Exception as E
-import System.Timeout(timeout)
 
 data App = App
 
@@ -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
@@ -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/Json.hs

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

yesod-core/test/YesodCoreTest/Meta.hs

@@ -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/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.10.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -8,7 +8,7 @@ synopsis:        Creation of type-safe, RESTful web applications.
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-core>
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.10
+cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 extra-source-files:
@@ -17,20 +17,17 @@ 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
+    build-depends:   base                  >= 4.9      && < 5
-    hs-source-dirs: src
-
-    build-depends:   base                  >= 4.10     && < 5
                    , aeson                 >= 1.0
-                   , attoparsec-aeson      >= 2.1
                    , auto-update
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.7.1
+                   , byteable
                    , bytestring            >= 0.10.2
                    , case-insensitive      >= 0.2
                    , cereal                >= 0.3
@@ -40,17 +37,16 @@ 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
                    , shakespeare           >= 2.0
                    , template-haskell      >= 2.11
                    , text                  >= 0.7
@@ -59,7 +55,7 @@ library
                    , 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
                    , wai-logger            >= 0.2
@@ -100,15 +96,17 @@ 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
+    hs-source-dirs: test, .
 
     other-modules: Hierarchy
                    Yesod.Routes.Class
@@ -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

@@ -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        && < 5
-    build-depends:   base                  >= 4.10     && < 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
@@ -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}

yesod-form/Yesod/Form/Fields.hs

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

yesod-form/Yesod/Form/Functions.hs

@@ -18,13 +18,10 @@ module Yesod.Form.Functions
     , wFormToMForm
       -- * Fields to Forms
     , wreq
-    , wreqMsg
     , wopt
     , mreq
-    , mreqMsg
     , mopt
     , areq
-    , areqMsg
     , aopt
       -- * Run a form
     , runFormPost
@@ -126,23 +123,7 @@ wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe a             -- ^ optional default value
      -> WForm m (FormResult a)
-wreq f fs = wreqMsg f fs MsgValueRequired
+wreq f fs = mFormToWForm . mreq f fs
-
--- | Same as @wreq@ but with your own message to be rendered in case the value
--- is not provided.
---
--- This is useful when you have several required fields on the page and you
--- want to differentiate between which fields were left blank. Otherwise the
--- user sees "Value is required" multiple times, which is ambiguous.
---
--- @since 1.6.7
-wreqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
-        => Field m a           -- ^ form field
-        -> FieldSettings site  -- ^ settings for this field
-        -> msg                 -- ^ message to use in case value is Nothing
-        -> Maybe a             -- ^ optional default value
-        -> WForm m (FormResult a)
-wreqMsg f fs msg = mFormToWForm . mreqMsg f fs msg
 
 -- | Converts a form field into monadic form 'WForm'. This field is optional,
 -- i.e.  if filled in, it returns 'Just a', if left empty, it returns
@@ -192,24 +173,7 @@ mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe a             -- ^ optional default value
      -> MForm m (FormResult a, FieldView site)
-mreq field fs mdef = mreqMsg field fs MsgValueRequired mdef
+mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
-
--- | Same as @mreq@ but with your own message to be rendered in case the value
--- is not provided.
---
--- This is useful when you have several required fields on the page and you
--- want to differentiate between which fields were left blank. Otherwise the
--- user sees "Value is required" multiple times, which is ambiguous.
---
--- @since 1.6.6
-mreqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
-        => Field m a           -- ^ form field
-        -> FieldSettings site  -- ^ settings for this field
-        -> msg                 -- ^ Message to use in case value is Nothing
-        -> Maybe a             -- ^ optional default value
-        -> MForm m (FormResult a, FieldView site)
-mreqMsg field fs msg mdef = mhelper field fs mdef formFailure FormSuccess True
-  where formFailure m l = FormFailure [renderMessage m l msg]
 
 -- | Converts a form field into monadic form. This field is optional, i.e.
 -- if filled in, it returns 'Just a', if left empty, it returns 'Nothing'.
@@ -265,27 +229,11 @@ 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
+     => Field m a
-     -> FieldSettings site  -- ^ settings for this field
+     -> FieldSettings site
-     -> Maybe a             -- ^ optional default value
+     -> Maybe a
      -> AForm m a
-areq f fs = areqMsg f fs MsgValueRequired
+areq a b = formToAForm . liftM (second return) . mreq a b
-
--- | Same as @areq@ but with your own message to be rendered in case the value
--- is not provided.
---
--- This is useful when you have several required fields on the page and you
--- want to differentiate between which fields were left blank. Otherwise the
--- user sees "Value is required" multiple times, which is ambiguous.
---
--- @since 1.6.7
-areqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
-        => Field m a           -- ^ form field
-        -> FieldSettings site  -- ^ settings for this field
-        -> msg                 -- ^ message to use in case value is Nothing
-        -> Maybe a             -- ^ optional default value
-        -> AForm m a
-areqMsg f fs msg = formToAForm . liftM (second return) . mreqMsg f fs msg
 
 -- | Applicative equivalent of 'mopt'.
 aopt :: MonadHandler m

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