[yesod-test] bump dependency on yesod-form

This brings the new functions introduced in #1628 into scope

This PR is untested, but I'm pretty sure it would work

Closes #1644

.azure/azure-linux-template.yml

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

.azure/azure-osx-template.yml

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

.azure/azure-pipelines.yml

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

.azure/azure-windows-template.yml

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

.github/workflows/tests.yml

@@ -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

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

README.md

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

cabal.project

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

demo/auth/email_auth_ses_mailer.hs

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

demo/subsite/WikiRoutes.hs

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

stack-lts-9.yaml

@@ -0,0 +1,39 @@
+resolver: lts-9.21
+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
+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
+- rio-0.1.8.0@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-nightly.yaml

@@ -0,0 +1,22 @@
+resolver: nightly-2019-11-11
+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
+extra-deps:
+- html-conduit-1.3.2.1
+- persistent-2.10.4
+- persistent-template-2.7.3
+- persistent-sqlite-2.10.5
+- authenticate-1.3.5

stack-nightly.yaml.lock

@@ -0,0 +1,47 @@
+# 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: html-conduit-1.3.2.1@sha256:61a9fe9e4c28c5feb7f68a84cac846a8db96bc46434e739f722fddaca7939529,2104
+    pantry-tree:
+      size: 504
+      sha256: 7e22a5f73125fa55b396e7a3deeadeba8d9c8e56668df5ad2ea0d5a3d240864a
+  original:
+    hackage: html-conduit-1.3.2.1
+- completed:
+    hackage: persistent-2.10.4@sha256:16c4c0823dd5e16bac4d607895ab0f4febd0626c020e5755ed1a52bf04068148,4738
+    pantry-tree:
+      size: 2094
+      sha256: b40d1783b539ddbbceaa827bf286d0b3bfcf76ca19e604c9d510b2a64008714e
+  original:
+    hackage: persistent-2.10.4
+- completed:
+    hackage: persistent-template-2.7.3@sha256:ac3e5e8c48e968b927bbf4e97162c52e7e417d69b05efeb1c581d7c682e043d2,2703
+    pantry-tree:
+      size: 560
+      sha256: fdfb2a721eb9c9831d7381d36bc52de0808a008ed3d553b6490080f337249684
+  original:
+    hackage: persistent-template-2.7.3
+- completed:
+    hackage: persistent-sqlite-2.10.5@sha256:50f8e3991fcf57d5744313fab8ecfa056d367d110aae43c03c45546445fea990,4993
+    pantry-tree:
+      size: 748
+      sha256: 42a52062ae795140362c2d929ba82f823904b785740a0837141c96eeec013115
+  original:
+    hackage: persistent-sqlite-2.10.5
+- completed:
+    hackage: authenticate-1.3.5@sha256:47b932a0f48a2ef2dff598519c5d6161214e6b5c1156732b5e157de5784b3798,2108
+    pantry-tree:
+      size: 845
+      sha256: 597a081d3c6796d9b0ca6125e455c9e4b05da2a8db2d35c57afc292a8db7b89e
+  original:
+    hackage: authenticate-1.3.5
+snapshots:
+- completed:
+    size: 418944
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2019/11/11.yaml
+    sha256: 12d3c25a6471bd6310df0fb5c064c24fc8aa8c5e9412d90e7980f36aa0cdd3f9
+  original: nightly-2019-11-11

stack-persistent-2-10.yaml

@@ -0,0 +1,20 @@
+resolver: lts-13.17
+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
+extra-deps:
+- persistent-2.10.0@rev:0
+- persistent-sqlite-2.10.0@rev:0
+- persistent-template-2.7.0@rev:0

stack-persistent-2-9.yaml

@@ -0,0 +1,19 @@
+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
+- ./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,4 +1,4 @@
-resolver: lts-18.3
+resolver: lts-13.4
 packages:
 - ./yesod-core
 - ./yesod-static
@@ -14,6 +14,3 @@ packages:
 - ./yesod
 - ./yesod-eventsource
 - ./yesod-websockets
-
-extra-deps:
-- attoparsec-aeson-2.1.0.0

stack.yaml.lock

@@ -3,17 +3,10 @@
 # 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
+packages: []
 snapshots:
 - completed:
-    sha256: 694573e96dca34db5636edb1fe6c96bb233ca0f9fb96c1ead1671cdfa9bd73e9
-    size: 585603
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/3.yaml
-  original: lts-18.3
+    size: 494984
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/4.yaml
+    sha256: ba80f9f1f517b9c79a3f32944558fa29837a152eae8dcd0891317338920c2ed8
+  original: lts-13.4

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
-    build-depends:   authenticate-oauth      >= 1.5       && < 1.8
-                   , base                    >= 4.10      && < 5
+    if flag(ghc7)
+        build-depends:   base                >= 4.3      && < 5
+        cpp-options:     -DGHC7
+    else
+        build-depends:   base                >= 4         && < 4.3
+    build-depends:   authenticate-oauth      >= 1.5       && < 1.7
                    , bytestring              >= 0.9.1.4
                    , text                    >= 0.7
                    , unliftio
                    , 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,53 +1,8 @@
 # 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
+## Unreleased
 
 * Email: Fix typo in `defaultEmailLoginHandler` template [#1605](https://github.com/yesodweb/yesod/pull/1605)
-* Remove unnecessary deriving of Typeable
 
 ## 1.6.8
 

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

yesod-auth/Yesod/Auth/Email.hs

@@ -31,16 +31,16 @@
 -- = Using JSON Endpoints
 --
 -- We are assuming that you have declared auth route as follows
---
+-- 
 -- @
 --    /auth AuthR Auth getAuth
 -- @
---
+-- 
 -- If you are using a different route, then you have to adjust the
 -- endpoints accordingly.
 --
 --     * Registration
---
+-- 
 -- @
 --       Endpoint: \/auth\/page\/email\/register
 --       Method: POST
@@ -49,9 +49,9 @@
 --                      "password": "myStrongPassword" (optional)
 --                  }
 -- @
---
+-- 
 --     * Forgot password
---
+--  
 -- @
 --       Endpoint: \/auth\/page\/email\/forgot-password
 --       Method: POST
@@ -59,16 +59,16 @@
 -- @
 --
 --     * Login
---
+--  
 -- @
 --       Endpoint: \/auth\/page\/email\/login
 --       Method: POST
---       JSON Data: {
+--       JSON Data: { 
 --                      "email": "myemail@domain.com",
 --                      "password": "myStrongPassword"
 --                  }
 -- @
---
+-- 
 --     * Set new password
 --
 -- @
@@ -113,34 +113,30 @@ module Yesod.Auth.Email
     , defaultRegisterHandler
     , defaultForgotPasswordHandler
     , defaultSetPasswordHandler
-     -- * Default helpers
-    , defaultRegisterHelper
     ) where
 
-import           Control.Applicative           ((<$>), (<*>))
-import qualified Crypto.Hash                   as H
-import qualified Crypto.Nonce                  as Nonce
-import           Data.Aeson.Types              (Parser, Result (..), parseMaybe,
-                                                withObject, (.:?))
-import           Data.ByteArray                (convert)
-import           Data.ByteString.Base16        as B16
-import           Data.Maybe                    (isJust)
-import           Data.Text                     (Text)
-import qualified Data.Text                     as T
-import qualified Data.Text                     as TS
-import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8)
-import qualified Data.Text.Encoding            as TE
-import           Data.Text.Encoding.Error      (lenientDecode)
-import           Data.Time                     (addUTCTime, getCurrentTime)
-import           Safe                          (readMay)
-import           System.IO.Unsafe              (unsafePerformIO)
-import qualified Text.Email.Validate
 import           Yesod.Auth
-import qualified Yesod.Auth.Message            as Msg
-import qualified Yesod.Auth.Util.PasswordStore as PS
+import qualified Yesod.Auth.Message       as Msg
 import           Yesod.Core
-import           Yesod.Core.Types              (TypedContent (TypedContent))
 import           Yesod.Form
+import qualified Yesod.Auth.Util.PasswordStore as PS
+import           Control.Applicative      ((<$>), (<*>))
+import qualified Crypto.Hash              as H
+import qualified Crypto.Nonce             as Nonce
+import           Data.ByteString.Base16   as B16
+import           Data.Text                (Text)
+import qualified Data.Text                as TS
+import qualified Data.Text                as T
+import           Data.Text.Encoding       (decodeUtf8With, encodeUtf8)
+import qualified Data.Text.Encoding       as TE
+import           Data.Text.Encoding.Error (lenientDecode)
+import           Data.Time                (addUTCTime, getCurrentTime)
+import           Safe                     (readMay)
+import           System.IO.Unsafe         (unsafePerformIO)
+import qualified Text.Email.Validate
+import           Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
+import           Data.Maybe (isJust)
+import Data.ByteArray (convert)
 
 loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
 loginR = PluginR "email" ["login"]
@@ -214,18 +210,6 @@ class ( YesodAuth site
     -- @since 1.1.0
     sendVerifyEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()
 
-    -- | Send an email to the given address to re-verify ownership in the case of
-    -- a password reset. This can be used to send a different email when a user
-    -- goes through the 'forgot password' flow as opposed to the 'account registration'
-    -- flow.
-    --
-    -- Default: Will call 'sendVerifyEmail', resulting in the same email getting sent
-    -- for both registrations and password resets.
-    --
-    -- @since 1.6.10
-    sendForgotPasswordEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()
-    sendForgotPasswordEmail = sendVerifyEmail
-
     -- | Get the verification key for the given email ID.
     --
     -- @since 1.1.0
@@ -242,7 +226,7 @@ class ( YesodAuth site
     --
     -- @since 1.4.20
     hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
-    hashAndSaltPassword password = liftIO $ saltPass password
+    hashAndSaltPassword = liftIO . saltPass
 
     -- | Verify a password matches the stored password for the given account.
     --
@@ -401,47 +385,17 @@ class ( YesodAuth site
       -> AuthHandler site TypedContent
     setPasswordHandler = defaultSetPasswordHandler
 
-
-    -- | Helper that controls what happens after a user registration
-    -- request is submitted. This method can be overridden to completely
-    -- customize what happens during the user registration process,
-    -- such as for handling additional fields in the registration form.
-    --
-    -- The default implementation is in terms of 'defaultRegisterHelper'.
-    --
-    -- @since: 1.6.9
-    registerHelper :: Route Auth
-                      -- ^ Where to sent the user in the event
-                      -- that registration fails
-                   -> AuthHandler site TypedContent
-    registerHelper = defaultRegisterHelper False False
-
-    -- | Helper that controls what happens after a forgot password
-    -- request is submitted. As with `registerHelper`, this method can
-    -- be overridden to customize the behavior when a user attempts
-    -- to recover their password.
-    --
-    -- The default implementation is in terms of 'defaultRegisterHelper'.
-    --
-    -- @since: 1.6.9
-    passwordResetHelper :: Route Auth
-                           -- ^ Where to sent the user in the event
-                           -- that the password reset fails
-                        -> AuthHandler site TypedContent
-    passwordResetHelper = defaultRegisterHelper True True
-
 authEmail :: (YesodAuthEmail m) => AuthPlugin m
 authEmail =
     AuthPlugin "email" dispatch emailLoginHandler
   where
-    dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent
     dispatch "GET" ["register"] = getRegisterR >>= sendResponse
     dispatch "POST" ["register"] = postRegisterR >>= sendResponse
     dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse
     dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse
     dispatch "GET" ["verify", eid, verkey] =
         case fromPathPiece eid of
-            Nothing   -> notFound
+            Nothing -> notFound
             Just eid' -> getVerifyR eid' verkey False >>= sendResponse
     dispatch "GET" ["verify", eid, verkey, hasSetPass] =
         case fromPathPiece eid of
@@ -488,13 +442,13 @@ defaultEmailLoginHandler toParent = do
         let userRes = UserLoginForm Control.Applicative.<$> emailRes
                                     Control.Applicative.<*> passwordRes
         let widget = do
-              [whamlet|
-                  #{extra}
-                  <div>
-                      ^{fvInput emailView}
-                  <div>
-                      ^{fvInput passwordView}
-              |]
+            [whamlet|
+                #{extra}
+                <div>
+                    ^{fvInput emailView}
+                <div>
+                    ^{fvInput passwordView}
+            |]
 
         return (userRes, widget)
     emailSettings emailMsg = do
@@ -548,11 +502,11 @@ defaultRegisterHandler = do
 
             let userRes = UserForm <$> emailRes
             let widget = do
-                  [whamlet|
-                      #{extra}
-                      ^{fvLabel emailView}
-                      ^{fvInput emailView}
-                  |]
+                [whamlet|
+                    #{extra}
+                    ^{fvLabel emailView}
+                    ^{fvInput emailView}
+                |]
 
             return (userRes, widget)
 
@@ -562,12 +516,12 @@ parseRegister = withObject "email" (\obj -> do
                                       pass <- obj .:? "password"
                                       return (email, pass))
 
-defaultRegisterHelper :: YesodAuthEmail master
-                      => Bool -- ^ Allow lookup via username in addition to email
-                      -> Bool -- ^ Set to `True` for forgot password flow, `False` for new account registration
-                      -> Route Auth
-                      -> AuthHandler master TypedContent
-defaultRegisterHelper allowUsername forgotPassword dest = do
+registerHelper :: YesodAuthEmail master
+               => Bool -- ^ allow usernames?
+               -> Bool -- ^ forgot password?
+               -> Route Auth
+               -> AuthHandler master TypedContent
+registerHelper allowUsername forgotPassword dest = do
     y <- getYesod
     checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
     result <- runInputPostResult $ (,)
@@ -579,7 +533,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                  _ -> do
                      (creds :: Result Value) <- parseCheckJsonBody
                      return $ case creds of
-                                  Error _     -> Nothing
+                                  Error _ -> Nothing
                                   Success val -> parseMaybe parseRegister val
 
     let eidentifier = case creds of
@@ -592,10 +546,10 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
 
     let mpass = case (forgotPassword, creds) of
                     (False, Just (_, mp)) -> mp
-                    _                     -> Nothing
+                    _ -> Nothing
 
     case eidentifier of
-      Left failMsg -> loginErrorMessageI dest failMsg
+      Left route -> loginErrorMessageI dest route
       Right identifier -> do
             mecreds <- getEmailCreds identifier
             registerCreds <-
@@ -619,23 +573,20 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                 Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
                 Just creds@(_, False, _, _) -> sendConfirmationEmail creds
                 Just creds@(_, True, _, _) -> do
-                  if forgotPassword
-                    then sendConfirmationEmail creds
+                  if forgotPassword then sendConfirmationEmail creds
                     else case emailPreviouslyRegisteredResponse identifier of
                       Just response -> response
-                      Nothing       -> sendConfirmationEmail creds
+                      Nothing -> sendConfirmationEmail creds
               where sendConfirmationEmail (lid, _, verKey, email) = do
                       render <- getUrlRender
                       tp <- getRouteToParent
                       let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey (isJust mpass)
-                      if forgotPassword
-                         then sendForgotPasswordEmail email verKey verUrl
-                         else sendVerifyEmail email verKey verUrl
+                      sendVerifyEmail email verKey verUrl
                       confirmationEmailSentResponse identifier
 
 
 postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
-postRegisterR = registerHelper registerR
+postRegisterR = registerHelper False False registerR
 
 getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html
 getForgotPasswordR = forgotPasswordHandler
@@ -662,11 +613,11 @@ defaultForgotPasswordHandler = do
 
         let forgotPasswordRes = ForgotPasswordForm <$> emailRes
         let widget = do
-              [whamlet|
-                  #{extra}
-                  ^{fvLabel emailView}
-                  ^{fvInput emailView}
-              |]
+            [whamlet|
+                #{extra}
+                ^{fvLabel emailView}
+                ^{fvInput emailView}
+            |]
         return (forgotPasswordRes, widget)
 
     emailSettings =
@@ -679,7 +630,7 @@ defaultForgotPasswordHandler = do
         }
 
 postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
-postForgotPasswordR = passwordResetHelper forgotPasswordR
+postForgotPasswordR = registerHelper True True forgotPasswordR
 
 getVerifyR :: YesodAuthEmail site
            => AuthEmailId site
@@ -698,9 +649,7 @@ getVerifyR lid key hasSetPass = do
                 Just uid -> do
                     setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
                     setLoginLinkKey uid
-                    let msgAv = if hasSetPass
-                                  then Msg.EmailVerified
-                                  else Msg.EmailVerifiedChangePass
+                    let msgAv = Msg.AddressVerified
                     selectRep $ do
                       provideRep $ do
                         addMessageI "success" msgAv
@@ -742,7 +691,7 @@ postLoginR = do
                      _ -> do
                        (creds :: Result Value) <- parseCheckJsonBody
                        case creds of
-                         Error _     -> return Nothing
+                         Error _ -> return Nothing
                          Success val -> return $ parseMaybe parseCreds val
 
     case midentifier of
@@ -782,8 +731,8 @@ getPasswordR = do
     maid <- maybeAuthId
     case maid of
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-        Just aid -> do
-            needOld <- needOldPassword aid
+        Just _ -> do
+            needOld <- maybe (return True) needOldPassword maid
             setPasswordHandler needOld
 
 -- | Default implementation of 'setPasswordHandler'.
@@ -811,29 +760,29 @@ defaultSetPasswordHandler needOld = do
 
         let passwordFormRes = PasswordForm <$> currentPasswordRes <*> newPasswordRes <*> confirmPasswordRes
         let widget = do
-              [whamlet|
-                  #{extra}
-                  <table>
-                      $if needOld
-                          <tr>
-                              <th>
-                                  ^{fvLabel currentPasswordView}
-                              <td>
-                                  ^{fvInput currentPasswordView}
-                      <tr>
-                          <th>
-                              ^{fvLabel newPasswordView}
-                          <td>
-                              ^{fvInput newPasswordView}
-                      <tr>
-                          <th>
-                              ^{fvLabel confirmPasswordView}
-                          <td>
-                              ^{fvInput confirmPasswordView}
-                      <tr>
-                          <td colspan="2">
-                              <input type=submit value=_{Msg.SetPassTitle}>
-              |]
+            [whamlet|
+                #{extra}
+                <table>
+                    $if needOld
+                        <tr>
+                            <th>
+                                ^{fvLabel currentPasswordView}
+                            <td>
+                                ^{fvInput currentPasswordView}
+                    <tr>
+                        <th>
+                            ^{fvLabel newPasswordView}
+                        <td>
+                            ^{fvInput newPasswordView}
+                    <tr>
+                        <th>
+                            ^{fvLabel confirmPasswordView}
+                        <td>
+                            ^{fvInput confirmPasswordView}
+                    <tr>
+                        <td colspan="2">
+                            <input type=submit value=_{Msg.SetPassTitle}>
+            |]
 
         return (passwordFormRes, widget)
     currentPasswordSettings =
@@ -873,7 +822,7 @@ postPasswordR = do
     maid <- maybeAuthId
     (creds :: Result Value) <- parseCheckJsonBody
     let jcreds = case creds of
-                   Error _     -> Nothing
+                   Error _ -> Nothing
                    Success val -> parseMaybe parsePassword val
     let doJsonParsing = isJust jcreds
     case maid of
@@ -885,7 +834,7 @@ postPasswordR = do
                 res <- runInputPostResult $ ireq textField "current"
                 let fcurrent = case res of
                                  FormSuccess currentPass -> Just currentPass
-                                 _                       -> Nothing
+                                 _ -> Nothing
                 let current = if doJsonParsing
                               then getThird jcreds
                               else fcurrent
@@ -904,9 +853,9 @@ postPasswordR = do
   where
     msgOk = Msg.PassUpdated
     getThird (Just (_,_,t)) = t
-    getThird Nothing        = Nothing
+    getThird Nothing = Nothing
     getNewConfirm (Just (a,b,_)) = Just (a,b)
-    getNewConfirm _              = Nothing
+    getNewConfirm _ = Nothing
     confirmPassword aid tm jcreds = do
         res <- runInputPostResult $ (,)
             <$> ireq textField "new"
@@ -915,7 +864,7 @@ postPasswordR = do
                     then getNewConfirm jcreds
                     else case res of
                            FormSuccess res' -> Just res'
-                           _                -> Nothing
+                           _ -> Nothing
         case creds of
           Nothing -> loginErrorMessageI setpassR Msg.PassMismatch
           Just (new, confirm) ->
@@ -935,7 +884,7 @@ postPasswordR = do
 
                      mr <- getMessageRender
                      selectRep $ do
-                         provideRep $
+                         provideRep $ 
                             fmap asHtml $ redirect $ afterPasswordRoute y
                          provideJsonMessage (mr msgOk)
 

yesod-auth/Yesod/Auth/GoogleEmail2.hs

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

yesod-auth/Yesod/Auth/Message.hs

@@ -40,8 +40,6 @@ data AuthMessage =
     | ConfirmationEmailSentTitle
     | ConfirmationEmailSent Text
     | AddressVerified
-    | EmailVerifiedChangePass
-    | EmailVerified
     | InvalidKeyTitle
     | InvalidKey
     | InvalidEmailPass
@@ -71,7 +69,6 @@ data AuthMessage =
     | LogoutTitle
     | AuthError
 {-# DEPRECATED Logout "Please, use LogoutTitle instead." #-}
-{-# DEPRECATED AddressVerified "Please, use EmailVerifiedChangePass instead." #-}
 
 -- | Defaults to 'englishMessage'.
 defaultMessage :: AuthMessage -> Text
@@ -94,9 +91,7 @@ englishMessage (ConfirmationEmailSent email) =
     "A confirmation e-mail has been sent to " `Data.Monoid.mappend`
     email `mappend`
     "."
-englishMessage AddressVerified = "Email address verified, please set a new password"
-englishMessage EmailVerifiedChangePass = "Email address verified, please set a new password"
-englishMessage EmailVerified = "Email address verified"
+englishMessage AddressVerified = "Address verified, please set a new password"
 englishMessage InvalidKeyTitle = "Invalid verification key"
 englishMessage InvalidKey = "I'm sorry, but that was an invalid verification key."
 englishMessage InvalidEmailPass = "Invalid email/password combination"
@@ -144,8 +139,6 @@ portugueseMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 portugueseMessage AddressVerified = "Endereço verificado, por favor entre com uma nova senha"
-portugueseMessage EmailVerifiedChangePass = "Endereço verificado, por favor entre com uma nova senha"
-portugueseMessage EmailVerified = "Endereço verificado"
 portugueseMessage InvalidKeyTitle = "Chave de verificação inválida"
 portugueseMessage InvalidKey = "Por favor nos desculpe, mas essa é uma chave de verificação inválida."
 portugueseMessage InvalidEmailPass = "E-mail e/ou senha inválidos"
@@ -194,8 +187,6 @@ spanishMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 spanishMessage AddressVerified = "Dirección verificada, por favor introduzca una contraseña"
-spanishMessage EmailVerifiedChangePass = "Dirección verificada, por favor introduzca una contraseña"
-spanishMessage EmailVerified = "Dirección verificada"
 spanishMessage InvalidKeyTitle = "Clave de verificación invalida"
 spanishMessage InvalidKey = "Lo sentimos, pero esa clave de verificación es inválida."
 spanishMessage InvalidEmailPass = "La combinación cuenta de correo/contraseña es inválida"
@@ -244,8 +235,6 @@ swedishMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 swedishMessage AddressVerified = "Adress verifierad, vänligen välj nytt lösenord"
-swedishMessage EmailVerifiedChangePass = "Adress verifierad, vänligen välj nytt lösenord"
-swedishMessage EmailVerified = "Adress verifierad"
 swedishMessage InvalidKeyTitle = "Ogiltig verifikationsnyckel"
 swedishMessage InvalidKey = "Tyvärr, du angav en ogiltig verifimationsnyckel."
 swedishMessage InvalidEmailPass = "Ogiltig epost/lösenord kombination"
@@ -282,21 +271,19 @@ germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"
 germanMessage LoginOpenID = "Login via OpenID"
 germanMessage LoginGoogle = "Login via Google"
 germanMessage LoginYahoo = "Login via Yahoo"
-germanMessage Email = "E-Mail"
-germanMessage UserName = "Benutzername"
+germanMessage Email = "Email"
+germanMessage UserName = "Benutzername" -- FIXME by Google Translate "user name"
 germanMessage Password = "Passwort"
 germanMessage CurrentPassword = "Aktuelles Passwort"
 germanMessage Register = "Registrieren"
 germanMessage RegisterLong = "Neuen Account registrieren"
-germanMessage EnterEmail = "Bitte die E-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."
+germanMessage EnterEmail = "Bitte die e-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."
 germanMessage ConfirmationEmailSentTitle = "Bestätigung verschickt."
 germanMessage (ConfirmationEmailSent email) =
     "Eine Bestätigung wurde an " `mappend`
     email `mappend`
     " versandt."
 germanMessage AddressVerified = "Adresse bestätigt, bitte neues Passwort angeben"
-germanMessage EmailVerifiedChangePass = "Adresse bestätigt, bitte neues Passwort angeben"
-germanMessage EmailVerified = "Adresse bestätigt"
 germanMessage InvalidKeyTitle = "Ungültiger Bestätigungsschlüssel"
 germanMessage InvalidKey = "Das war leider ein ungültiger Bestätigungsschlüssel"
 germanMessage InvalidEmailPass = "Ungültiger Nutzername oder Passwort"
@@ -308,23 +295,24 @@ germanMessage ConfirmPass = "Bestätigen"
 germanMessage PassMismatch = "Die Passwörter stimmen nicht überein"
 germanMessage PassUpdated = "Passwort überschrieben"
 germanMessage Facebook = "Login über Facebook"
-germanMessage LoginViaEmail = "Login via E-Mail"
+germanMessage LoginViaEmail = "Login via e-Mail"
 germanMessage InvalidLogin = "Ungültiger Login"
 germanMessage NowLoggedIn = "Login erfolgreich"
-germanMessage LoginTitle = "Anmelden"
+germanMessage LoginTitle = "Log In"
 germanMessage PleaseProvideUsername = "Bitte Nutzername angeben"
 germanMessage PleaseProvidePassword = "Bitte Passwort angeben"
-germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben"
-germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter"
+germanMessage NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben"
+germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter"
 germanMessage PasswordResetTitle = "Passwort zurücksetzen"
-germanMessage ProvideIdentifier = "E-Mail-Adresse oder Nutzername"
-germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen"
-germanMessage PasswordResetPrompt = "Nach Einhabe der E-Mail-Adresse oder des Nutzernamen wird eine E-Mail zugesendet mit welcher das Passwort zurückgesetzt werden kann."
+germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"
+germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen"
+germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann."
 germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"
-germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO
-germanMessage Logout = "Abmelden"
-germanMessage LogoutTitle = "Abmelden"
-germanMessage AuthError = "Fehler beim Anmelden"
+-- TODO
+germanMessage i@(IdentifierNotFound _) = englishMessage i
+germanMessage Logout = "Ausloggen" -- FIXME by Google Translate
+germanMessage LogoutTitle = "Ausloggen" -- FIXME by Google Translate
+germanMessage AuthError = "Autorisierungsfehler" -- FIXME by Google Translate
 
 frenchMessage :: AuthMessage -> Text
 frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"
@@ -344,8 +332,6 @@ frenchMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 frenchMessage AddressVerified = "Votre adresse électronique a été validée, merci de choisir un nouveau mot de passe."
-frenchMessage EmailVerifiedChangePass = "Votre adresse électronique a été validée, merci de choisir un nouveau mot de passe."
-frenchMessage EmailVerified = "Votre adresse électronique a été validée"
 frenchMessage InvalidKeyTitle = "Clef de validation incorrecte"
 frenchMessage InvalidKey = "Désolé, mais cette clef de validation est incorrecte"
 frenchMessage InvalidEmailPass = "La combinaison de ce mot de passe et de cette adresse électronique n'existe pas."
@@ -393,8 +379,6 @@ norwegianBokmålMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 norwegianBokmålMessage AddressVerified = "Adresse verifisert, vennligst sett et nytt passord."
-norwegianBokmålMessage EmailVerifiedChangePass = "Adresse verifisert, vennligst sett et nytt passord."
-norwegianBokmålMessage EmailVerified = "Adresse verifisert"
 norwegianBokmålMessage InvalidKeyTitle = "Ugyldig verifiseringsnøkkel"
 norwegianBokmålMessage InvalidKey = "Beklager, men det var en ugyldig verifiseringsnøkkel."
 norwegianBokmålMessage InvalidEmailPass = "Ugyldig e-post/passord-kombinasjon"
@@ -443,8 +427,6 @@ japaneseMessage (ConfirmationEmailSent email) =
     email `mappend`
     " に送信しました"
 japaneseMessage AddressVerified = "アドレスは認証されました。新しいパスワードを設定してください"
-japaneseMessage EmailVerifiedChangePass = "アドレスは認証されました。新しいパスワードを設定してください"
-japaneseMessage EmailVerified = "アドレスは認証されました"
 japaneseMessage InvalidKeyTitle = "認証キーが無効です"
 japaneseMessage InvalidKey = "申し訳ありません。無効な認証キーです"
 japaneseMessage InvalidEmailPass = "メールアドレスまたはパスワードが無効です"
@@ -494,8 +476,6 @@ finnishMessage (ConfirmationEmailSent email) =
     "."
 
 finnishMessage AddressVerified = "Sähköpostiosoite vahvistettu. Anna uusi salasana"
-finnishMessage EmailVerifiedChangePass = "Sähköpostiosoite vahvistettu. Anna uusi salasana"
-finnishMessage EmailVerified = "Sähköpostiosoite vahvistettu"
 finnishMessage InvalidKeyTitle = "Virheellinen varmistusavain"
 finnishMessage InvalidKey = "Valitettavasti varmistusavain on virheellinen."
 finnishMessage InvalidEmailPass = "Virheellinen sähköposti tai salasana."
@@ -544,8 +524,6 @@ chineseMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 chineseMessage AddressVerified = "地址验证成功，请设置新密码"
-chineseMessage EmailVerifiedChangePass = "地址验证成功，请设置新密码"
-chineseMessage EmailVerified = "地址验证成功"
 chineseMessage InvalidKeyTitle = "无效的验证码"
 chineseMessage InvalidKey = "对不起，验证码无效。"
 chineseMessage InvalidEmailPass = "无效的邮箱/密码组合"
@@ -591,8 +569,6 @@ czechMessage ConfirmationEmailSentTitle = "Potvrzovací e-mail odeslán"
 czechMessage (ConfirmationEmailSent email) =
     "Potvrzovací e-mail byl odeslán na " `mappend` email `mappend` "."
 czechMessage AddressVerified = "Adresa byla ověřena, prosím nastavte si nové heslo"
-czechMessage EmailVerifiedChangePass = "Adresa byla ověřena, prosím nastavte si nové heslo"
-czechMessage EmailVerified = "Adresa byla ověřena"
 czechMessage InvalidKeyTitle = "Neplatný ověřovací klíč"
 czechMessage InvalidKey = "Bohužel, ověřovací klíč je neplatný."
 czechMessage InvalidEmailPass = "Neplatná kombinace e-mail/heslo"
@@ -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.8
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -8,6 +7,7 @@ maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        Authentication for Yesod.
 category:        Web, Yesod
 stability:       Stable
+cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-auth>
@@ -20,10 +20,8 @@ flag network-uri
   default: True
 
 library
-    default-language: Haskell2010
-    build-depends:   base                    >= 4.10      && < 5
+    build-depends:   base                    >= 4         && < 5
                    , aeson                   >= 0.7
-                   , attoparsec-aeson        >= 2.1
                    , authenticate            >= 1.3.4
                    , base16-bytestring
                    , base64-bytestring
@@ -45,7 +43,7 @@ library
                    , http-types
                    , memory
                    , nonce                   >= 1.0.2     && < 1.1
-                   , persistent              >= 2.8
+                   , persistent              >= 2.8       && < 2.11
                    , 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)
-import Distribution.Simple.PackageDescription (readGenericPackageDescription)
-#elif MIN_VERSION_Cabal(2, 2, 0)
+#if MIN_VERSION_Cabal(2, 2, 0)
 import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
 #elif MIN_VERSION_Cabal(2, 0, 0)
 import Distribution.PackageDescription.Parse (readGenericPackageDescription)
 #else
 import Distribution.PackageDescription.Parse (readPackageDescription)
 #endif
-#if MIN_VERSION_Cabal(3, 6, 0)
-import Distribution.Utils.Path
-#endif
 import Distribution.PackageDescription.Configuration (flattenPackageDescription)
 import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)
 import Distribution.Verbosity (normal)
@@ -67,18 +62,18 @@ addHandlerInteractive :: IO ()
 addHandlerInteractive = do
     cabal <- getCabal
     let routeInput = do
-          putStr "Name of route (without trailing R): "
-          hFlush stdout
-          name <- getLine
-          checked <- checkRoute name cabal
-          case checked of
-              Left err@EmptyRoute -> (error . show) err
-              Left err@RouteCaseError -> print err >> routeInput
-              Left err@(RouteExists _) -> do
-                print err
-                putStrLn "Try another name or leave blank to exit"
-                routeInput
-              Right p -> return p
+        putStr "Name of route (without trailing R): "
+        hFlush stdout
+        name <- getLine
+        checked <- checkRoute name cabal
+        case checked of
+            Left err@EmptyRoute -> (error . show) err
+            Left err@RouteCaseError -> print err >> routeInput
+            Left err@(RouteExists _) -> do
+              print err
+              putStrLn "Try another name or leave blank to exit"
+              routeInput
+            Right p -> return p
 
     routePair <- routeInput
     putStr "Enter route pattern (ex: /entry/#EntryId): "
@@ -89,22 +84,13 @@ addHandlerInteractive = do
     methods <- getLine
     addHandlerFiles cabal routePair pattern methods
 
-getRoutesFilePath :: IO FilePath
-getRoutesFilePath = do
-    let oldPath = "config/routes"
-    oldExists <- doesFileExist oldPath
-    pure $ if oldExists
-        then oldPath
-        else "config/routes.yesodroutes"
-
 addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO ()
 addHandlerFiles cabal (name, handlerFile) pattern methods = do
     src <- getSrcDir cabal
     let applicationFile = concat [src, "/Application.hs"]
     modify applicationFile $ fixApp name
     modify cabal $ fixCabal name
-    routesPath <- getRoutesFilePath
-    modify routesPath $ fixRoutes name pattern methods
+    modify "config/routes" $ fixRoutes name pattern methods
     writeFile handlerFile $ mkHandler name pattern methods
     specExists <- doesFileExist specFile
     unless specExists $
@@ -252,8 +238,4 @@ getSrcDir cabal = do
 #endif
     let buildInfo = allBuildInfo pd
         srcDirs = concatMap hsSourceDirs buildInfo
-#if MIN_VERSION_Cabal(3, 6, 0)
-    return $ maybe "." getSymbolicPath $ listToMaybe srcDirs
-#else
     return $ fromMaybe "." $ listToMaybe srcDirs
-#endif

yesod-bin/ChangeLog.md

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

yesod-bin/Devel.hs

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

yesod-bin/Keter.hs

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

yesod-bin/README.md

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

yesod-bin/main.hs

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

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.6.2.2
+version:         1.6.0.4
 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,138 +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

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

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

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

@@ -1,9 +1,7 @@
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE TemplateHaskell     #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE TemplateHaskell   #-}
 module Yesod.Core.Class.Yesod where
 
 import           Yesod.Core.Content
@@ -54,10 +52,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 +70,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 +87,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
@@ -547,17 +531,16 @@ widgetToPageContent :: Yesod site
                     => WidgetFor site ()
                     -> HandlerFor site (PageContent (Route site))
 widgetToPageContent w = do
- jsAttrs <- jsAttributesHandler
- 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'
 
@@ -627,7 +610,7 @@ widgetToPageContent w = do
             ^{regularScriptLoad}
         |]
 
-    return $ PageContent title description headAll $
+    return $ PageContent title headAll $
         case jsLoader master of
             BottomOfBody -> bodyScript
             _ -> body

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

@@ -64,7 +64,6 @@ import qualified Data.Conduit.Internal as CI
 
 import qualified Data.Aeson as J
 import Data.Text.Lazy.Builder (toLazyText)
-import Data.Void (Void, absurd)
 import Yesod.Core.Types
 import Text.Lucius (Css, renderCss)
 import Text.Julius (Javascript, unJavascript)
@@ -104,8 +103,6 @@ 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
@@ -279,8 +276,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

yesod-core/src/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
-  where
-    bits = finiteBitSize (undefined :: Int)
-    bytes = div (bits + 7) 8
-    bsToInt = S.foldl' (\v i -> shiftL v 8 .|. fromIntegral i) 0
+defaultGen = Random.getStdRandom Random.next
 
 -- | Pure low level function to construct WAI application. Usefull
 -- when you need not standard way to run your app, or want to embed it
@@ -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/src/Yesod/Core/Handler.hs

@@ -8,8 +8,8 @@
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TemplateHaskell            #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -245,7 +245,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 +261,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 +370,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
--- the control flow of an HTTP request (on the outer 'HandlerFor'
+-- Sometimes you want to run an inner 'HandlerT' action outside
+-- the control flow of an HTTP request (on the outer 'HandlerT'
 -- action).  For example, you may want to spawn a new thread:
 --
 -- @
@@ -382,30 +381,30 @@ getCurrentRoute = rheRoute <$> askHandlerEnv
 -- getFooR = do
 --   runInnerHandler <- handlerToIO
 --   liftIO $ forkIO $ runInnerHandler $ do
---     /Code here runs inside HandlerFor but on a new thread./
---     /This is the inner HandlerFor./
+--     /Code here runs inside GHandler but on a new thread./
+--     /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
--- on the inner 'HandlerFor', however:
+-- Most of the environment from the outer 'GHandler' is preserved
+-- 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
--- 'HandlerFor' (e.g., on the @forkIO@ example above, a response
+-- This allows the inner 'GHandler' to outlive the outer
+-- '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 +429,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
@@ -1038,7 +1037,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
@@ -1227,10 +1226,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 +1238,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 +1464,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
--- implies that you can run any @HandlerFor@ action. However, since a streaming
+-- Note that, for ease of use, the underlying monad is a @HandlerT@. This
+-- 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 +1476,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.
-    -- This is a safe assumption assuming the HandlerFor is run correctly.
+    -- environment provided by the server is the same one used in HandlerT.
+    -- This is a safe assumption assuming the HandlerT is run correctly.
     return $ TypedContent ctype $ ContentSource
            $ transPipe (lift . flip unHandlerFor hd) src
 

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

@@ -129,7 +129,7 @@ parseWaiRequest env session useToken mmaxBodySize =
                 -- Already have a token, use it.
                 Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs
                 -- Don't have a token, get a random generator and make a new one.
-                Nothing -> Right $ fmap Just . randomString 40
+                Nothing -> Right $ fmap Just . randomString 10
         | otherwise = Left Nothing
 
 textQueryString :: W.Request -> [(Text, Text)]

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

@@ -1,28 +1,13 @@
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE PatternGuards       #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE TemplateHaskell     #-}
-{-# LANGUAGE TupleSections       #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Yesod.Core.Internal.Run
-  ( toErrorHandler
-  , errFromShow
-  , basicRunHandler
-  , handleError
-  , handleContents
-  , evalFallback
-  , runHandler
-  , safeEh
-  , runFakeHandler
-  , yesodRunner
-  , yesodRender
-  , resolveApproot
-  )
-  where
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards     #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE FlexibleContexts  #-}
+module Yesod.Core.Internal.Run where
+
 
-import qualified Control.Exception as EUnsafe
 import 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)
-    (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
+    (finalSession, contents1) <- evalFallback contents0 (ghsSession state)
+    (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
     contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
 
     -- Convert the HandlerContents into the final YesodResponse
@@ -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.
-runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
+-- @HandlerT@'s return value.
+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,7 +298,7 @@ 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)
@@ -354,7 +333,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/src/Yesod/Core/Internal/TH.hs

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

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

@@ -32,9 +32,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)
@@ -137,8 +134,8 @@ parseInsecureJsonBody = do
 parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
 parseCheckJsonBody = do
     mct <- lookupHeader "content-type"
-    case fmap contentTypeHeaderIsJson mct of
-        Just True -> parseInsecureJsonBody
+    case fmap (B8.takeWhile (/= ';')) mct of
+        Just "application/json" -> parseInsecureJsonBody
         _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct
 
 -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
@@ -221,12 +218,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/src/Yesod/Core/Types.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleInstances          #-}
@@ -8,7 +9,6 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
 module Yesod.Core.Types where
 
 import Data.Aeson (ToJSON)
@@ -37,6 +37,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 +57,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 +184,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 +198,7 @@ data YesodRunnerEnv site = YesodRunnerEnv
     , yreSite           :: !site
     , yreSessionBackend :: !(Maybe SessionBackend)
     , yreGen            :: !(IO Int)
-    -- ^ Generate a random number uniformly distributed in the full
-    -- range of 'Int'.
-    --
-    -- Note: Before 1.6.20, the default value generates pseudo-random
-    -- number in an unspecified range. The range size may not be a power
-    -- of 2. Since 1.6.20, the default value uses a secure entropy source
-    -- and generates in the full range of 'Int'.
+    -- ^ Generate a random number
     , yreGetMaxExpires  :: !(IO Text)
     }
 
@@ -243,7 +233,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
@@ -295,10 +285,9 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
 --
 -- > PageContent url -> HtmlUrl url
 data PageContent url = PageContent
-    { pageTitle       :: !Html
-    , pageDescription :: !(Maybe Text)
-    , pageHead        :: !(HtmlUrl url)
-    , pageBody        :: !(HtmlUrl url)
+    { pageTitle :: !Html
+    , pageHead  :: !(HtmlUrl url)
+    , pageBody  :: !(HtmlUrl url)
     }
 
 data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
@@ -339,29 +328,12 @@ newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
 -- | Responses to indicate some form of an error occurred.
 data ErrorResponse =
       NotFound
-        -- ^ The requested resource was not found.
-        -- Examples of when this occurs include when an incorrect URL is used, or @yesod-persistent@'s 'get404' doesn't find a value.
-        -- HTTP status: 404.
     | InternalError !Text
-        -- ^ Some sort of unexpected exception.
-        -- If your application uses `throwIO` or `error` to throw an exception, this is the form it would take.
-        -- HTTP status: 500.
     | InvalidArgs ![Text]
-        -- ^ Indicates some sort of invalid or missing argument, like a missing query parameter or malformed JSON body.
-        -- Examples Yesod functions that send this include 'requireCheckJsonBody' and @Yesod.Auth.GoogleEmail2@.
-        -- HTTP status: 400.
     | NotAuthenticated
-        -- ^ Indicates the user is not logged in.
-        -- This is thrown when 'isAuthorized' returns 'AuthenticationRequired'.
-        -- HTTP code: 401.
     | PermissionDenied !Text
-        -- ^ Indicates the user doesn't have permission to access the requested resource.
-        -- This is thrown when 'isAuthorized' returns 'Unauthorized'.
-        -- HTTP code: 403.
     | BadMethod !H.Method
-        -- ^ Indicates the URL would have been valid if used with a different HTTP method (e.g. a GET was used, but only POST is handled.)
-        -- HTTP code: 405.
-    deriving (Show, Eq, Generic)
+    deriving (Show, Eq, Typeable, Generic)
 instance NFData ErrorResponse
 
 ----- header stuff
@@ -394,7 +366,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 +381,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 +388,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 b1 b2 b3 b4 b5 b6 b7 b8 = GWData
+    GWData a1 a2 a3 a4 a5 a6 a7 <>
+      GWData b1 b2 b3 b4 b5 b6 b7 = GWData
         (mappend a1 b1)
         (mappend a2 b2)
         (mappend a3 b3)
         (mappend a4 b4)
-        (mappend a5 b5)
-        (unionWith mappend a6 b6)
+        (unionWith mappend a5 b5)
+        (mappend a6 b6)
         (mappend a7 b7)
-        (mappend a8 b8)
 
 data HandlerContents =
       HCContent !H.Status !TypedContent
@@ -442,6 +411,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 +440,9 @@ instance PrimMonad (WidgetFor site) where
     primitive = liftIO . primitive
 -- | @since 1.4.38
 instance MonadUnliftIO (WidgetFor site) where
-  {-# INLINE withRunInIO #-}
-  withRunInIO inner = WidgetFor $ \x -> inner $ flip unWidgetFor x
+  {-# INLINE askUnliftIO #-}
+  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 +460,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 +479,9 @@ instance MonadReader (HandlerData site site) (HandlerFor site) where
 
 -- | @since 1.4.38
 instance MonadUnliftIO (HandlerFor site) where
-  {-# INLINE withRunInIO #-}
-  withRunInIO inner = HandlerFor $ \x -> inner $ flip unHandlerFor x
+  {-# INLINE askUnliftIO #-}
+  askUnliftIO = HandlerFor $ \r ->
+                return (UnliftIO (flip unHandlerFor r))
 
 instance MonadThrow (HandlerFor site) where
     throwM = liftIO . throwM
@@ -580,8 +552,9 @@ instance MonadReader (HandlerData child master) (SubHandlerFor child master) whe
 
 -- | @since 1.4.38
 instance MonadUnliftIO (SubHandlerFor child master) where
-  {-# INLINE withRunInIO #-}
-  withRunInIO inner = SubHandlerFor $ \x -> inner $ flip unSubHandlerFor x
+  {-# INLINE askUnliftIO #-}
+  askUnliftIO = SubHandlerFor $ \r ->
+                return (UnliftIO (flip unSubHandlerFor r))
 
 instance MonadThrow (SubHandlerFor child master) where
     throwM = liftIO . throwM

yesod-core/src/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.
---
--- 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
+-- | Set the page title. Calling 'setTitle' multiple times overrides previously
+-- set values.
 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.
---
--- n.b. See comments for @setTitle@
+-- | Set the page title. Calling 'setTitle' multiple times overrides previously
+-- set values.
 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/src/Yesod/Routes/Parse.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE PatternGuards #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
 module Yesod.Routes.Parse
@@ -11,7 +12,6 @@ module Yesod.Routes.Parse
     , TypeTree (..)
     , dropBracket
     , nameToType
-    , isTvar
     ) where
 
 import Language.Haskell.TH.Syntax
@@ -36,15 +36,9 @@ parseRoutes = QuasiQuoter { quoteExp = x }
             [] -> lift res
             z -> error $ unlines $ "Overlapping routes: " : map show z
 
--- | Same as 'parseRoutes', but uses an external file instead of quasiquotation.
---
--- The recommended file extension is @.yesodroutes@.
 parseRoutesFile :: FilePath -> Q Exp
 parseRoutesFile = parseRoutesFileWith parseRoutes
 
--- | Same as 'parseRoutesNoCheck', but uses an external file instead of quasiquotation.
---
--- The recommended file extension is @.yesodroutes@.
 parseRoutesFileNoCheck :: FilePath -> Q Exp
 parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck
 
@@ -265,13 +259,8 @@ ttToType (TTApp x y) = ttToType x `AppT` ttToType y
 ttToType (TTList t) = ListT `AppT` ttToType t
 
 nameToType :: String -> Type
-nameToType t = if isTvar t
-               then VarT $ mkName t
-               else ConT $ mkName t
-
-isTvar :: String -> Bool
-isTvar (h:_) = isLower h
-isTvar _     = False
+nameToType t@(h:_) | isLower h = VarT $ mkName t
+nameToType t = ConT $ mkName t
 
 pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
 pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)

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

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

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

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

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

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

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

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

yesod-core/test/RouteSpec.hs

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

yesod-core/test/YesodCoreTest.hs

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

yesod-core/test/YesodCoreTest/Breadcrumb.hs

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

yesod-core/test/YesodCoreTest/Cache.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE Rank2Types #-}
 module YesodCoreTest.Cache
     ( cacheTest
@@ -21,8 +22,10 @@ import qualified Data.ByteString.Lazy.Char8 as L8
 data C = C
 
 newtype V1 = V1 Int
+    deriving Typeable
 
 newtype V2 = V2 Int
+    deriving Typeable
 
 mkYesod "C" [parseRoutes|
 /    RootR GET

yesod-core/test/YesodCoreTest/ErrorHandling.hs

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

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

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

yesod-core/test/YesodCoreTest/Meta.hs

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

yesod-core/test/YesodCoreTest/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.16.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,17 +17,15 @@ extra-source-files:
   test/YesodCoreTest/JsLoaderSites/Bottom.hs
   test/en.msg
   test/test.hs
-  test/fixtures/routes_with_line_continuations.yesodroutes
+  test/fixtures/routes_with_line_continuations
   ChangeLog.md
   README.md
 
 library
-    default-language: Haskell2010
     hs-source-dirs: src
 
-    build-depends:   base                  >= 4.10     && < 5
+    build-depends:   base                  >= 4.9      && < 5
                    , aeson                 >= 1.0
-                   , attoparsec-aeson      >= 2.1
                    , auto-update
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.7.1
@@ -40,7 +38,6 @@ library
                    , containers            >= 0.2
                    , cookie                >= 0.4.3    && < 0.5
                    , deepseq               >= 1.3
-                   , entropy
                    , fast-logger           >= 2.2
                    , http-types            >= 0.7
                    , memory
@@ -49,8 +46,9 @@ library
                    , 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 +57,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,12 +98,14 @@ library
                      Yesod.Routes.TH.RouteAttrs
 
     ghc-options:     -Wall
+    -- Following line added due to: https://github.com/yesodweb/yesod/issues/545
+    -- This looks like a GHC bug
+    extensions:      MultiParamTypeClasses
 
     -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
-    other-extensions:      TemplateHaskell
+    extensions:      TemplateHaskell
 
 test-suite test-routes
-    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: RouteSpec.hs
     hs-source-dirs: test, src
@@ -122,7 +122,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 +135,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 +146,6 @@ test-suite tests
                    YesodCoreTest.Header
                    YesodCoreTest.Csrf
                    YesodCoreTest.ErrorHandling
-                   YesodCoreTest.ErrorHandling.CustomApp
                    YesodCoreTest.Exceptions
                    YesodCoreTest.InternalRequest
                    YesodCoreTest.JsLoader
@@ -157,13 +155,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 +167,6 @@ test-suite tests
                    YesodCoreTest.StubSslOnly
                    YesodCoreTest.StubStrictSameSite
                    YesodCoreTest.StubUnsecured
-                   YesodCoreTest.SubSub
-                   YesodCoreTest.SubSubData
                    YesodCoreTest.WaiSubsite
                    YesodCoreTest.Widget
                    YesodCoreTest.YesodTest
@@ -207,10 +198,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.10     && < 5
+    build-depends:   base                  >= 4        && < 5
                    , blaze-builder
                    , conduit               >= 1.3
                    , transformers

yesod-form-multi/ChangeLog.md

@@ -1,30 +1,5 @@
 # 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
+* Added `Yesod.Form.MultiInput` which supports multi-input forms without needing to submit the form to add an input field [#1601](https://github.com/yesodweb/yesod/pull/1601)

yesod-form-multi/README.md

@@ -1,5 +1,7 @@
 ## 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`.
 
-Intended as an alternative to `Yesod.Form.MassInput`.
+# Limitations
+- If the user adds too many fields then there is currently no support for a "delete button" although fields submitted empty are considered to be deleted.

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

@@ -17,19 +17,16 @@ module Yesod.Form.MultiInput
     , mmulti
     , amulti
     , bs3Settings
-    , bs3FASettings
     , bs4Settings
-    , bs4FASettings
     ) where
 
 import Control.Arrow (second)
 import Control.Monad (liftM)
 import Control.Monad.Trans.RWS (ask, tell)
 import qualified Data.Map as Map
-import Data.Maybe (fromJust, listToMaybe, fromMaybe, isJust)
+import Data.Maybe (fromJust, listToMaybe, fromMaybe)
 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
@@ -44,132 +41,43 @@ 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
+-- @since 1.6.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.
+    { msAddClass :: Text -- ^ Class to be applied to the "add another" button.
     , 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
+-- @since 1.6.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)
+bs3Settings = MultiSettings "btn btn-default" (Just errW)
     where
         errW err = 
             [whamlet|
-                <span .help-block>#{err}
+                <span .help-block .error-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)
+bs4Settings = MultiSettings "btn btn-basic" (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
@@ -184,19 +92,20 @@ amulti field fs defs minVals ms = formToAForm $
         mform = do
             (fr, MultiView {..}) <- mmulti field fs defs minVals ms
 
-            let (fv : _) = mvFields
-                widget = do
+            let widget = do
                     [whamlet|
-                        $maybe tooltip <- fvTooltip fv
-                            <small .#{msTooltipClass ms}>#{tooltip}
-
                         ^{fvInput mvCounter}
 
                         $forall fv <- mvFields
                             ^{fvInput fv}
 
+                            $maybe err <- fvErrors fv
+                                $maybe errW <- msErrWidget ms
+                                    ^{errW err}
+
                         ^{fvInput mvAddBtn}
                     |]
+                (fv : _) = mvFields
                 view = FieldView
                     { fvLabel = fvLabel fv
                     , fvTooltip = Nothing
@@ -221,10 +130,11 @@ mmulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
     -> 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
+mmulti field fs@FieldSettings {..} defs minVals ms = do
+    fieldClass <- newFormIdent
+    let fs' = fs {fsAttrs = addClass fieldClass fsAttrs}
+        minVals' = if minVals < 0 then 0 else minVals
+    mhelperMulti field fs' fieldClass defs minVals' ms
 
 -- Helper function, does most of the work for mmulti.
 mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
@@ -235,22 +145,21 @@ mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMe
     -> Int
     -> MultiSettings site
     -> MForm m (FormResult [a], MultiView site)
-mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals MultiSettings {..} = do
+mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals MultiSettings {..} = do
     mp <- askParams
     (_, site, langs) <- ask
     name <- maybe newFormIdent return fsName
-    theId <- lift $ maybe newIdent return fsId
+    theId <- maybe newFormIdent return fsId
     cName <- newFormIdent
-    cid <- lift newIdent
-    addBtnId <- lift newIdent
-    delBtnPrefix <- lift newIdent
+    cid <- newFormIdent
+    addBtnId <- newFormIdent 
 
     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]]
+        mkNames c = [(mkName i, mkId i) | i <- [0 .. c]]
         onMissingSucc _ _ = FormSuccess Nothing
         onMissingFail m l = FormFailure [renderMessage m l MsgValueRequired]
         isSuccNothing r = case r of
@@ -265,7 +174,7 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
         Just p -> mkRes intField cfs p mfs cName onMissingFail FormSuccess
 
     -- generate counter view
-    cView <- mkView intField cfs cr Nothing Nothing msWrapperErrClass cid cName True
+    cView <- mkView intField cfs cr cid cName True
 
     let counter = case cRes of
             FormSuccess c -> c
@@ -277,74 +186,17 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
             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}'));
-                    });                    
-                |]
+        Just p -> mapM (\n -> mkRes field fs p mfs n onMissingSucc (FormSuccess . Just)) (map fst $ mkNames counter)
 
     -- 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
+        let mkView' ((n,i), r@(res, _)) = do
+                fv <- mkView field fs r i n False
                 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
+                [] -> [((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
@@ -362,77 +214,23 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
                 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
+                <button ##{addBtnId} .#{msAddClass} type="button">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};
+                    var extraFields = 0;
+                    $("#" + #{addBtnId}).click(function() {
+                        extraFields++;
+                        var newNumber = parseInt(#{show counter}) + extraFields;
                         $("#" + #{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}');
+                        var newElem = $("." + #{fieldClass}).first().clone();
+                        newElem.val("").attr('name', newName).attr('id', newId);
+                        newElem.insertBefore("#" + #{addBtnId})
                     });
                 |]
 
@@ -445,7 +243,7 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
             , fvRequired = False
             }
 
-    return (res, MultiView cView fvs btnView wrapperClass)
+    return (res, MultiView cView fvs btnView)
 
 -- Search for the given field's name in the environment,
 -- parse any values found and construct a FormResult.
@@ -476,42 +274,21 @@ 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
+mkView Field {..} FieldSettings {..} (res, val) 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
+        , fvInput = fieldView theId name fsAttrs val isReq
+        , fvErrors =
+            case res of
+                FormFailure [e] -> Just $ toHtml e
+                _ -> Nothing
         , fvRequired = isReq
         }

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

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

yesod-form/ChangeLog.md

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

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/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
-                      , split, splitOn
+                      , intercalate, isPrefixOf, null, unpack, pack, 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
 
@@ -179,20 +169,20 @@ timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Tim
 timeField = timeFieldTypeTime
 
 -- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'.
---
+-- 
 -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
 --
--- @since 1.4.2
-timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
+-- Since 1.4.2
+timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay  
 timeFieldTypeTime = timeFieldOfType "time"
 
 -- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system).
 --
 -- This function exists for backwards compatibility with the old implementation of 'timeField', which used to use @type="text"@. Consider using 'timeField' or 'timeFieldTypeTime' for improved UX and validation from the browser.
---
+-- 
 -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
 --
--- @since 1.4.2
+-- Since 1.4.2
 timeFieldTypeText :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
 timeFieldTypeText = timeFieldOfType "text"
 
@@ -225,7 +215,7 @@ $newline never
   where showVal = either id (pack . renderHtml)
 
 -- | A newtype wrapper around a 'Text' whose 'ToMarkup' instance converts newlines to HTML @\<br>@ tags.
---
+-- 
 -- (When text is entered into a @\<textarea>@, newline characters are used to separate lines.
 -- If this text is then placed verbatim into HTML, the lines won't be separated, thus the need for replacing with @\<br>@ tags).
 -- If you don't need this functionality, simply use 'unTextarea' to access the raw text.
@@ -354,7 +344,7 @@ timeParser = do
         if i < 0 || i >= 60
             then fail $ show $ msg $ pack xy
             else return $ fromIntegral (i :: Int)
-
+            
 -- | Creates an input with @type="email"@. Yesod will validate the email's correctness according to RFC5322 and canonicalize it by removing comments and whitespace (see "Text.Email.Validate").
 emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
 emailField = Field
@@ -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.
---
--- @since 1.7.0
-selectFieldListGrouped :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
-                => [(msg, [(msg, a)])]
-                -> Field (HandlerFor site) a
-selectFieldListGrouped = selectField . optionsPairsGrouped
-
--- | Creates a @\<select>@ tag with optional @\<optgroup>@s for selecting one option. Example usage:
+-- | Creates a @\<select>@ tag for selecting one option. Example usage:
 --
 -- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing
 selectField :: (Eq a, RenderMessage site FormMessage)
@@ -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,58 +512,31 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
 radioField :: (Eq a, RenderMessage site FormMessage)
            => HandlerFor site (OptionList a)
            -> Field (HandlerFor site) a
-radioField = withRadioField
-    (\theId optionWidget -> [whamlet|
+radioField = selectFieldHelper
+    (\theId _name _attrs inside -> [whamlet|
 $newline never
-<div .radio>
-    <label for=#{theId}-none>
-        <div>
-            ^{optionWidget}
-            _{MsgSelectNone}
+<div ##{theId}>^{inside}
 |])
-    (\theId value _isSel text optionWidget -> [whamlet|
+    (\theId name isSel -> [whamlet|
 $newline never
-<div .radio>
-    <label for=#{theId}-#{value}>
-        <div>
-            ^{optionWidget}
-            \#{text}
+<label .radio for=#{theId}-none>
+    <div>
+        <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
+        _{MsgSelectNone}
 |])
-
-
--- | Allows the user to place the option radio widget somewhere in
---   the template.
---   For example: If you want a table of radio options to select.
---   'radioField' is an example on how to use this function.
---
---   @since 1.7.2
-withRadioField :: (Eq a, RenderMessage site FormMessage)
-           => (Text -> WidgetFor site ()-> WidgetFor site ()) -- ^ nothing case for mopt
-           -> (Text ->  Text -> Bool -> Text -> WidgetFor site () -> WidgetFor site ()) -- ^ cases for values
-           -> HandlerFor site (OptionList a)
-           -> Field (HandlerFor site) a
-withRadioField nothingFun optFun =
-  selectFieldHelper outside onOpt inside Nothing
-  where
-    outside theId _name _attrs inside' = [whamlet|
+    (\theId name attrs value isSel text -> [whamlet|
 $newline never
-<div ##{theId}>^{inside'}
-|]
-    onOpt theId name isSel = nothingFun theId $ [whamlet|
-$newline never
-<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
-|]
-    inside theId name attrs value isSel display =
-       optFun theId value isSel display [whamlet|
-<input id=#{theId}-#{(value)} type=radio name=#{name} value=#{(value)} :isSel:checked *{attrs}>
-|]
-
+<label .radio for=#{theId}-#{value}>
+    <div>
+        <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
+        \#{text}
+|])
 
 -- | Creates a group of radio buttons to answer the question given in the message. Radio buttons are used to allow differentiating between an empty response (@Nothing@) and a no response (@Just False@). Consider using the simpler 'checkBoxField' if you don't need to make this distinction.
 --
 -- If this field is optional, the first radio button is labeled "\<None>", the second \"Yes" and the third \"No".
 --
--- If this field is required, the first radio button is labeled \"Yes" and the second \"No".
+-- If this field is required, the first radio button is labeled \"Yes" and the second \"No". 
 --
 -- (Exact label titles will depend on localization).
 boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
@@ -618,7 +570,7 @@ $newline never
       t -> Left $ SomeMessage $ MsgInvalidBool t
     showVal = either (\_ -> False)
 
--- | Creates an input with @type="checkbox"@.
+-- | Creates an input with @type="checkbox"@. 
 --   While the default @'boolField'@ implements a radio button so you
 --   can differentiate between an empty response (@Nothing@) and a no
 --   response (@Just False@), this simpler checkbox field returns an empty
@@ -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.
---
--- Extended by 'OptionListGrouped' in 1.7.0.
-data OptionList a
-  = OptionList
+data OptionList a = OptionList
     { olOptions :: [Option a]
     , olReadExternal :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue').
     }
-  | OptionListGrouped
-    { olOptionsGrouped :: [(Text, [Option a])]
-    , olReadExternalGrouped :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue').
-    }
 
--- | Convert grouped 'OptionList' to a normal one.
---
--- @since 1.7.0
-flattenOptionList :: OptionList a -> OptionList a
-flattenOptionList (OptionListGrouped os re) = OptionList (concatMap snd os) re
-flattenOptionList ol = ol
-
--- | @since 1.4.6
+-- | Since 1.4.6
 instance Functor OptionList where
-    fmap f (OptionList options readExternal) =
+    fmap f (OptionList options readExternal) = 
       OptionList ((fmap.fmap) f options) (fmap f . readExternal)
-    fmap f (OptionListGrouped options readExternal) =
-      OptionListGrouped (map (\(g, os) -> (g, (fmap.fmap) f os)) options) (fmap f . readExternal)
 
 -- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternal' function.
 mkOptionList :: [Option a] -> OptionList a
@@ -679,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 $ render optsFlat val `notElem` map optionExternalValue optsFlat
-          opts'' <- handlerToWidget opts'
-          case opts'' of
-            OptionList{} -> constructOptions theId name attrs val isReq optsFlat
-            OptionListGrouped{olOptionsGrouped=grps} -> do
-                  forM_ grps $ \(grp, opts) -> do
-                    case grpHdr of
-                      Just hdr -> hdr grp
-                      Nothing -> return ()
-                    constructOptions theId name attrs val isReq opts
+            unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
+            flip mapM_ opts $ \opt -> inside
+                theId
+                name
+                ((if isReq then (("required", "required"):) else id) attrs)
+                (optionExternalValue opt)
+                ((render opts val) == optionExternalValue opt)
+                (optionDisplay opt)
     , fieldEnctype = UrlEncoded
     }
   where
@@ -868,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,52 +864,11 @@ prependZero t0 = if T.null t1
                            then "-0." `T.append` (T.drop 2 t1)
                            else t1
 
-  where t1 = T.dropWhile (==' ') t0
+  where t1 = T.dropWhile ((==) ' ') t0
 
 -- $optionsOverview
 -- These functions create inputs where one or more options can be selected from a list.
---
+-- 
 -- The basic datastructure used is an 'Option', which combines a user-facing display value, the internal Haskell value being selected, and an external 'Text' stored as the @value@ in the form (used to map back to the internal value). A list of these, together with a function mapping from an external value back to a Haskell value, form an 'OptionList', which several of these functions take as an argument.
---
+-- 
 -- Typically, you won't need to create an 'OptionList' directly and can instead make one with functions like 'optionsPairs' or 'optionsEnum'. Alternatively, you can use functions like 'selectFieldList', which use their @[(msg, a)]@ parameter to create an 'OptionList' themselves.
-
--- | Creates an input with @type="color"@.
---   The input value must be provided in hexadecimal format #rrggbb.
---
--- @since 1.7.1
-colorField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
-colorField = Field
-    { fieldParse = parseHelper $ \s ->
-        if isHexColor $ unpack s then Right s
-        else Left $ MsgInvalidHexColorFormat s
-    , fieldView = \theId name attrs val _ -> [whamlet|
-$newline never
-<input ##{theId} name=#{name} *{attrs} type=color value=#{either id id val}>
-|]
-    , fieldEnctype = UrlEncoded
-    }
-  where
-      isHexColor :: String -> Bool
-      isHexColor ['#',a,b,c,d,e,f] = all isHexDigit [a,b,c,d,e,f]
-      isHexColor _ = False
-
--- | Creates an input with @type="datetime-local"@.
---   The input value must be provided in YYYY-MM-DD(T| )HH:MM[:SS] format.
---
--- @since 1.7.6
-datetimeLocalField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m LocalTime
-datetimeLocalField = Field
-    { fieldParse = parseHelper $ \s -> case T.split (\c -> (c == 'T') || (c == ' ')) s of
-        [d,t] -> do
-            day <- parseDate $ unpack d
-            time <- parseTime t
-            Right $ LocalTime day time
-        _ -> Left $ MsgInvalidDatetimeFormat s
-    , fieldView = \theId name attrs val isReq -> [whamlet|
-$newline never
-<input type=datetime-local ##{theId} name=#{name} value=#{showVal val} *{attrs} :isReq:required>
-|]
-    , fieldEnctype = UrlEncoded
-    }
-  where
-    showVal = either id (pack . show)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

yesod-form/Yesod/Form/Types.hs

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

yesod-form/yesod-form.cabal

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

yesod-newsfeed/yesod-newsfeed.cabal

@@ -14,7 +14,7 @@ description:     API docs and the README are available at <http://www.stackage.o
 extra-source-files: README.md ChangeLog.md
 
 library
-    build-depends:   base                 >= 4.10     && < 5
+    build-depends:   base                 >= 4        && < 5
                    , yesod-core           >= 1.6      && < 1.7
                    , time                 >= 1.1.4
                    , shakespeare          >= 2.0

yesod-persistent/ChangeLog.md

@@ -1,27 +1,5 @@
 # ChangeLog for yesod-persistent
 
-## 1.6.0.8
-
-* Add support for `persistent-2.14` [#1706](https://github.com/yesodweb/yesod/pull/1760)
-
-## 1.6.0.7
-
-* Add support for persistent 2.13. [#1723](https://github.com/yesodweb/yesod/pull/1723)
-
-## 1.6.0.6
-
-* Add support for persistent 2.12
-
-## 1.6.0.5
-
-* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)
-
-## 1.6.0.4
-
-* Fix test suite to be compatible with latest `persistent-template`
-* See https://github.com/yesodweb/persistent/pull/1002
-* [#1649](https://github.com/yesodweb/yesod/pull/1649/files)
-
 ## 1.6.0.3
 
 * Replace call to `connPrepare` with `getStmtConn`. [#1635](https://github.com/yesodweb/yesod/issues/1635)