.github/ISSUE_TEMPLATE.md

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

.github/PULL_REQUEST_TEMPLATE.md

@@ -2,7 +2,7 @@ Before submitting your PR, check that you've:
 
 - [ ] Bumped the version number
 - [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html)
-- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddocks for new, public APIs
+- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock
 
 After submitting your PR:
 
@@ -11,4 +11,4 @@ After submitting your PR:
 
 <!---Thanks so much for contributing! :)
 
-_If these checkboxes don't apply to your PR, you can delete them_-->
+_If these checkboxes don't apply to your PR, you can delete them_-->

.github/workflows/tests.yml

@@ -1,56 +0,0 @@
-name: Tests
-
-on:
-    pull_request:
-    push:
-        branches:
-        - master
-
-jobs:
-  build:
-    name: CI
-    runs-on: ${{ matrix.os }}
-    strategy:
-      fail-fast: false
-      matrix:
-        os: [ubuntu-latest, macos-latest, windows-latest]
-        args:
-        #- "--resolver nightly"
-        - "--resolver nightly-2022-02-11"
-        - "--resolver lts-18"
-        - "--resolver lts-16"
-        - "--resolver lts-14"
-        - "--resolver lts-12"
-        - "--resolver lts-11"
-        # Bugs in GHC make it crash too often to be worth running
-        exclude:
-          - os: windows-latest
-            args: "--resolver nightly"
-          - os: macos-latest
-            args: "--resolver lts-16"
-          - os: macos-latest
-            args: "--resolver lts-14"
-          - os: macos-latest
-            args: "--resolver lts-12"
-          - os: macos-latest
-            args: "--resolver lts-11"
-
-    steps:
-      - name: Clone project
-        uses: actions/checkout@v2
-
-# Getting weird OS X errors...
-#      - name: Cache dependencies
-#        uses: actions/cache@v1
-#        with:
-#          path: ~/.stack
-#          key: ${{ runner.os }}-${{ matrix.resolver }}-${{ hashFiles('stack.yaml') }}
-#          restore-keys: |
-#            ${{ runner.os }}-${{ matrix.resolver }}-
-
-      - name: Build and run tests
-        shell: bash
-        run: |
-            set -ex
-            stack --version
-            stack test --fast --no-terminal ${{ matrix.args }}

.gitignore

@@ -4,7 +4,6 @@
 *.hi
 dist/
 dist-stack/
-stack.yaml.lock
 .stack-work
 *.swp
 client_session_key.aes
@@ -22,8 +21,3 @@ tarballs/
 .ghc
 .stackage
 .bash_history
-
-# OS X
-.DS_Store
-*.yaml.lock
-dist-newstyle/

.travis.yml

@@ -0,0 +1,197 @@
+# This is the complex Travis configuration, which is intended for use
+# on open source libraries which need compatibility across multiple GHC
+# versions, must work with cabal-install, and should be
+# cross-platform. For more information and other options, see:
+#
+# https://docs.haskellstack.org/en/stable/travis_ci/
+#
+# Copy these contents into the root directory of your Github project in a file
+# named .travis.yml
+
+# Use new container infrastructure to enable caching
+sudo: false
+
+# Choose a lightweight base image; we provide our own build tools.
+language: generic
+
+# Caching so the next build will be fast too.
+cache:
+  directories:
+  - $HOME/.ghc
+  - $HOME/.cabal
+  - $HOME/.stack
+
+# The different configurations we want to test. We have BUILD=cabal which uses
+# cabal-install, and BUILD=stack which uses Stack. More documentation on each
+# of those below.
+#
+# We set the compiler values here to tell Travis to use a different
+# cache file per set of arguments.
+#
+# If you need to have different apt packages for each combination in the
+# matrix, you can use a line such as:
+#     addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}
+matrix:
+  include:
+  # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:
+  # https://github.com/hvr/multi-ghc-travis
+  #- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
+  #  compiler: ": #GHC 7.0.4"
+  #  addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+  #- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
+  #  compiler: ": #GHC 7.2.2"
+  #  addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+  #- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
+  #  compiler: ": #GHC 7.4.2"
+  #  addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+  #- env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
+  #  compiler: ": #GHC 7.6.3"
+  #  addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+  - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7
+    compiler: ": #GHC 7.8.4"
+    addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+  - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7
+    compiler: ": #GHC 7.10.3"
+    addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+  - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
+    compiler: ": #GHC 8.0.2"
+    addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+
+  # Build with the newest GHC and cabal-install. This is an accepted failure,
+  # see below.
+  - env: BUILD=cabal GHCVER=head  CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
+    compiler: ": #GHC HEAD"
+    addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+
+  # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS
+  # variable, such as using --stack-yaml to point to a different file.
+  - env: BUILD=stack ARGS=""
+    compiler: ": #stack default"
+    addons: {apt: {packages: [libgmp-dev]}}
+
+  - env: BUILD=stack ARGS="--resolver lts-6"
+    compiler: ": #stack 7.10.3"
+    addons: {apt: {packages: [libgmp-dev]}}
+
+  - env: BUILD=stack ARGS="--resolver lts-8"
+    compiler: ": #stack 8.0.2"
+    addons: {apt: {packages: [libgmp-dev]}}
+
+  # Nightly builds are allowed to fail
+  - env: BUILD=stack ARGS="--resolver nightly"
+    compiler: ": #stack nightly"
+    addons: {apt: {packages: [libgmp-dev]}}
+
+  # Build on OS X in addition to Linux
+  - env: BUILD=stack ARGS=""
+    compiler: ": #stack default osx"
+    os: osx
+
+  - env: BUILD=stack ARGS="--resolver lts-6"
+    compiler: ": #stack 7.10.3 osx"
+    os: osx
+
+  - env: BUILD=stack ARGS="--resolver lts-8"
+    compiler: ": #stack 8.0.2 osx"
+    os: osx
+
+  - env: BUILD=stack ARGS="--resolver nightly"
+    compiler: ": #stack nightly osx"
+    os: osx
+
+  allow_failures:
+  - env: BUILD=cabal GHCVER=head  CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
+  - env: BUILD=stack ARGS="--resolver nightly"
+  - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7
+  - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7
+
+before_install:
+# Using compiler above sets CC to an invalid value, so unset it
+- unset CC
+
+# We want to always allow newer versions of packages when building on GHC HEAD
+- CABALARGS=""
+- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi
+
+# Download and unpack the stack executable
+- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH
+- mkdir -p ~/.local/bin
+- |
+  if [ `uname` = "Darwin" ]
+  then
+    travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin
+  else
+    travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
+  fi
+
+  # Use the more reliable S3 mirror of Hackage
+  mkdir -p $HOME/.cabal
+  echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config
+  echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config
+
+  if [ "$CABALVER" != "1.16" ]
+  then
+    echo 'jobs: $ncpus' >> $HOME/.cabal/config
+  fi
+
+install:
+- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
+- if [ -f configure.ac ]; then autoreconf -i; fi
+- |
+  set -ex
+  if [ "$ARGS" = "--resolver nightly" ]
+  then
+    stack --install-ghc $ARGS build cabal-install
+    stack --install-ghc $ARGS solver --update-config
+  fi
+  set +ex
+
+script:
+- |
+  set -ex
+  case "$BUILD" in
+    stack)
+      if [ `uname` = "Darwin" ]
+      then
+        # Build dependencies with -O0 as well
+        echo "apply-ghc-options: everything" >> stack.yaml
+
+        # Avoid OOM for building Cabal
+        stack --install-ghc --no-terminal $ARGS build Cabal --fast
+
+        # Use slightly less intensive options on OS X due to Travis timeouts
+        stack --install-ghc --no-terminal $ARGS test --fast
+      else
+        # Avoid OOM for building Cabal
+        stack --install-ghc --no-terminal $ARGS build Cabal --fast
+
+        stack --install-ghc --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --pedantic
+      fi
+      ;;
+    cabal)
+      cabal --version
+      travis_retry cabal update
+
+      # Get the list of packages from the stack.yaml file
+      PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')
+
+      cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
+
+      ORIGDIR=$(pwd)
+      for dir in $PACKAGES
+      do
+        cd $dir
+        cabal check || [ "$CABALVER" == "1.16" ]
+        cabal sdist
+        PKGVER=$(cabal info . | awk '{print $2;exit}')
+        SRC_TGZ=$PKGVER.tar.gz
+        cd dist
+        tar zxfv "$SRC_TGZ"
+        cd "$PKGVER"
+        cabal configure --enable-tests
+        cabal build
+        cd $ORIGDIR
+      done
+      ;;
+  esac
+  set +ex

CODE_OF_CONDUCT.md

@@ -1,74 +1,13 @@
-# Contributor Covenant Code of Conduct
+# Contributor Code of Conduct
 
-## Our Pledge
+Always be nice.
 
-In the interest of fostering an open and welcoming environment, we as
+When communicating online treat people the way you would if
-contributors and maintainers pledge to making participation in our project and
+they were standing next to you.
-our community a harassment-free experience for everyone, regardless of age, body
-size, disability, ethnicity, gender identity and expression, level of experience,
-education, socio-economic status, nationality, personal appearance, race,
-religion, or sexual identity and orientation.
 
-## Our Standards
+Don't forget to be nice whenever representing the
+project to others outside the project.
 
-Examples of behavior that contributes to creating a positive environment
+If you are not nice, apologize.
-include:
-
-* Using welcoming and inclusive language
-* Being respectful of differing viewpoints and experiences
-* Gracefully accepting constructive criticism
-* Focusing on what is best for the community
-* Showing empathy towards other community members
-
-Examples of unacceptable behavior by participants include:
-
-* The use of sexualized language or imagery and unwelcome sexual attention or
-  advances
-* Trolling, insulting/derogatory comments, and personal or political attacks
-* Public or private harassment
-* Publishing others' private information, such as a physical or electronic
-  address, without explicit permission
-* Other conduct which could reasonably be considered inappropriate in a
-  professional setting
-
-## Our Responsibilities
-
-Project maintainers are responsible for clarifying the standards of acceptable
-behavior and are expected to take appropriate and fair corrective action in
-response to any instances of unacceptable behavior.
-
-Project maintainers have the right and responsibility to remove, edit, or
-reject comments, commits, code, wiki edits, issues, and other contributions
-that are not aligned to this Code of Conduct, or to ban temporarily or
-permanently any contributor for other behaviors that they deem inappropriate,
-threatening, offensive, or harmful.
-
-## Scope
-
-This Code of Conduct applies both within project spaces and in public spaces
-when an individual is representing the project or its community. Examples of
-representing a project or community include using an official project e-mail
-address, posting via an official social media account, or acting as an appointed
-representative at an online or offline event. Representation of a project may be
-further defined and clarified by project maintainers.
-
-## Enforcement
-
-Instances of abusive, harassing, or otherwise unacceptable behavior may be
-reported by contacting the project team at `michael at snoyman dot com`. All
-complaints will be reviewed and investigated and will result in a response that
-is deemed necessary and appropriate to the circumstances. The project team is
-obligated to maintain confidentiality with regard to the reporter of an incident.
-Further details of specific enforcement policies may be posted separately.
-
-Project maintainers who do not follow or enforce the Code of Conduct in good
-faith may face temporary or permanent repercussions as determined by other
-members of the project's leadership.
-
-## Attribution
-
-This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4,
-available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html
-
-[homepage]: https://www.contributor-covenant.org
 
+If someone is not being nice, tell them in a respectful way or tell a project maintainer: we care about fostering a welcoming community.

README

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

README.md

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

ReleaseNotes.md

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

appveyor.yml

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

cabal.project

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

demo/auth/email_auth_ses_mailer.hs

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

demo/subsite/WikiRoutes.hs

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

sources.txt

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

stack.yaml

@@ -1,19 +1,15 @@
-resolver: lts-18.3
+resolver: lts-8.12
 packages:
-- ./yesod-core
+  - ./yesod-core
-- ./yesod-static
+  - ./yesod-static
-- ./yesod-persistent
+  - ./yesod-persistent
-- ./yesod-newsfeed
+  - ./yesod-newsfeed
-- ./yesod-form
+  - ./yesod-form
-- ./yesod-form-multi
+  - ./yesod-auth
-- ./yesod-auth
+  - ./yesod-auth-oauth
-- ./yesod-auth-oauth
+  - ./yesod-sitemap
-- ./yesod-sitemap
+  - ./yesod-test
-- ./yesod-test
+  - ./yesod-bin
-- ./yesod-bin
+  - ./yesod
-- ./yesod
+  - ./yesod-eventsource
-- ./yesod-eventsource
+  - ./yesod-websockets
-- ./yesod-websockets
-
-extra-deps:
-- attoparsec-aeson-2.1.0.0

stack.yaml.lock

@@ -1,19 +0,0 @@
-# This file was autogenerated by Stack.
-# You should not edit this file by hand.
-# For more information, please see the documentation at:
-#   https://docs.haskellstack.org/en/stable/lock_files
-
-packages:
-- completed:
-    hackage: attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
-    pantry-tree:
-      sha256: 294c3a8a19a7ddad58097e18c624c6b34894b3c4a4cc490759cb31d842db242a
-      size: 114
-  original:
-    hackage: attoparsec-aeson-2.1.0.0
-snapshots:
-- completed:
-    sha256: 694573e96dca34db5636edb1fe6c96bb233ca0f9fb96c1ead1671cdfa9bd73e9
-    size: 585603
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/3.yaml
-  original: lts-18.3

yesod-auth-oauth/ChangeLog.md

@@ -1,25 +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)
-
-## 1.6.0
-
-* Upgrade to yesod-core 1.6.0
-
 ## 1.4.2
 
 * Fix warnings

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

@@ -1,9 +1,5 @@
-{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 module Yesod.Auth.OAuth
     ( authOAuth
     , oauthUrl
@@ -16,7 +12,7 @@ module Yesod.Auth.OAuth
     ) where
 import           Control.Applicative      as A ((<$>), (<*>))
 import           Control.Arrow            ((***))
-import           UnliftIO.Exception
+import           Control.Exception.Lifted
 import           Control.Monad.IO.Class
 import           Data.ByteString          (ByteString)
 import           Data.Maybe
@@ -24,6 +20,7 @@ import           Data.Text                (Text)
 import qualified Data.Text                as T
 import           Data.Text.Encoding       (decodeUtf8With, encodeUtf8)
 import           Data.Text.Encoding.Error (lenientDecode)
+import           Data.Typeable
 import           Web.Authenticate.OAuth
 import           Yesod.Auth
 import           Yesod.Form
@@ -31,42 +28,34 @@ import           Yesod.Core
 
 data YesodOAuthException = CredentialError String Credential
                          | SessionError String
-                           deriving Show
+                           deriving (Show, Typeable)
 
 instance Exception YesodOAuthException
 
 oauthUrl :: Text -> AuthRoute
 oauthUrl name = PluginR name ["forward"]
 
-authOAuth :: forall master. YesodAuth master
+authOAuth :: YesodAuth m
           => OAuth                        -- ^ 'OAuth' data-type for signing.
-          -> (Credential -> IO (Creds master)) -- ^ How to extract ident.
+          -> (Credential -> IO (Creds m)) -- ^ How to extract ident.
-          -> AuthPlugin master
+          -> AuthPlugin m
 authOAuth oauth mkCreds = AuthPlugin name dispatch login
   where
     name = T.pack $ oauthServerName oauth
     url = PluginR name []
     lookupTokenSecret = bsToText . fromMaybe "" . lookup "oauth_token_secret" . unCredential
-
-    oauthSessionName :: Text
     oauthSessionName = "__oauth_token_secret"
 
-    dispatch
-      :: Text
-      -> [Text]
-      -> AuthHandler master TypedContent
     dispatch "GET" ["forward"] = do
-        render <- getUrlRender
+        render <- lift getUrlRender
         tm <- getRouteToParent
         let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
-        manager <- authHttpManager
+        master <- lift getYesod
-        tok <- getTemporaryCredential oauth' manager
+        tok <- lift $ getTemporaryCredential oauth' (authHttpManager master)
         setSession oauthSessionName $ lookupTokenSecret tok
         redirect $ authorizeUrl oauth' tok
-    dispatch "GET" [] = do
+    dispatch "GET" [] = lift $ do
-      tokSec <- lookupSession oauthSessionName >>= \case
+      Just tokSec <- lookupSession oauthSessionName
-        Just t -> return t
-        Nothing -> liftIO $ fail "lookupSession could not find session"
       deleteSession oauthSessionName
       reqTok <-
         if oauthVersion oauth == OAuth10
@@ -83,8 +72,8 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
                                 , ("oauth_token", encodeUtf8 oaTok)
                                 , ("oauth_token_secret", encodeUtf8 tokSec)
                                 ]
-      manager <- authHttpManager
+      master <- getYesod
-      accTok <- getAccessToken oauth reqTok manager
+      accTok <- getAccessToken oauth reqTok (authHttpManager master)
       creds  <- liftIO $ mkCreds accTok
       setCredsRedirect creds
     dispatch _ _ = notFound
@@ -124,7 +113,7 @@ authTwitter :: YesodAuth m
             -> ByteString -- ^ Consumer Secret
             -> AuthPlugin m
 authTwitter key secret = authTwitter' key secret "screen_name"
-{-# DEPRECATED authTwitter "Use authTwitterUsingUserId instead" #-}
+{-# DEPRECATED authTwitter "Use authTwitterUsingUserID instead" #-}
 
 -- | Twitter plugin which uses Twitter's /user_id/ as ID.
 --

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

@@ -1,6 +1,5 @@
-cabal-version:   >= 1.10
 name:            yesod-auth-oauth
-version:         1.6.1
+version:         1.4.2
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
@@ -8,21 +7,28 @@ maintainer:      Michael Litchard
 synopsis:        OAuth Authentication for Yesod.
 category:        Web, Yesod
 stability:       Stable
+cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-auth-oauth>
 extra-source-files: README.md ChangeLog.md
 
+flag ghc7
+
 library
-    default-language: Haskell2010
+    if flag(ghc7)
-    build-depends:   authenticate-oauth      >= 1.5       && < 1.8
+        build-depends:   base                >= 4.3      && < 5
-                   , base                    >= 4.10      && < 5
+        cpp-options:     -DGHC7
+    else
+        build-depends:   base                >= 4         && < 4.3
+    build-depends:   authenticate-oauth      >= 1.5       && < 1.7
                    , bytestring              >= 0.9.1.4
+                   , yesod-core              >= 1.4       && < 1.5
+                   , yesod-auth              >= 1.4       && < 1.5
                    , text                    >= 0.7
-                   , unliftio
+                   , yesod-form              >= 1.4       && < 1.5
-                   , yesod-auth              >= 1.6       && < 1.7
+                   , transformers            >= 0.2.2     && < 0.6
-                   , yesod-core              >= 1.6       && < 1.7
+                   , lifted-base             >= 0.2       && < 0.3
-                   , yesod-form              >= 1.6       && < 1.8
     exposed-modules: Yesod.Auth.OAuth
     ghc-options:     -Wall
 

yesod-auth/ChangeLog.md

@@ -1,107 +1,3 @@
-# ChangeLog for yesod-auth
-
-## 1.6.11.2
-
-* Add support for aeson 2.2 [#1820](https://github.com/yesodweb/yesod/pull/1820)
-
-## 1.6.11.1
-
-* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
-
-## 1.6.11
-
-* Add support for aeson 2
-
-## 1.6.10.5
-
-* Fix German translations of AuthMessage [#1741](https://github.com/yesodweb/yesod/pull/1741)
-
-## 1.6.10.4
-
-* Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737)
-
-## 1.6.10.3
-
-* Relax bounds for yesod-form 1.7
-
-## 1.6.10.2
-
-* Relax bounds for persistent 2.12
-
-## 1.6.10.1
-
-* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)
-
-## 1.6.10
-
-* Updated `AuthMessage` data type in `Yesod.Auth.Message` to accommodate registration flow where password is supplied initially: deprecated `AddressVerified` and split into `EmailVerifiedChangePass` and `EmailVerified`
-* Fixed a bug in `getVerifyR` related to the above, where the incorrect message was displayed when password was set during registration
-* Added `sendForgotPasswordEmail` to `YesodAuthEmail` typeclass, allowing for different emails for account registration vs. forgot password
-* See pull request [#1662](https://github.com/yesodweb/yesod/pull/1662)
-
-## 1.6.9
-
-* Added `registerHelper` and `passwordResetHelper` methods to the `YesodAuthEmail` class, allowing for customizing behavior for user registration and forgot password requests [#1660](https://github.com/yesodweb/yesod/pull/1660)
-* Exposed `defaultRegisterHelper` as default implementation for the above methods
-
-## 1.6.8.1
-
-* Email: Fix typo in `defaultEmailLoginHandler` template [#1605](https://github.com/yesodweb/yesod/pull/1605)
-* Remove unnecessary deriving of Typeable
-
-## 1.6.8
-
-* Dummy: Add support for JSON submissions [#1619](https://github.com/yesodweb/yesod/pull/1619)
-
-## 1.6.7
-
-* Redirect behavior of `clearCreds` depends on request type [#1598](https://github.com/yesodweb/yesod/pull/1598)
-
-## 1.6.6
-
-* Deprecated `Yesod.Auth.GoogleEmail2`, see [#1579](https://github.com/yesodweb/yesod/issues/1579) and [migration blog post](https://pbrisbin.com/posts/googleemail2_deprecation/)
-
-## 1.6.5
-
-* Add support for persistent 2.9 [#1516](https://github.com/yesodweb/yesod/pull/1516), [#1561](https://github.com/yesodweb/yesod/pull/1561)
-
-## 1.6.4.1
-
-* Email: Fix forgot-password endpoint [#1537](https://github.com/yesodweb/yesod/pull/1537)
-
-## 1.6.4
-
-* Make `registerHelper` configurable [#1524](https://github.com/yesodweb/yesod/issues/1524)
-* Email: Immediately register with a password [#1389](https://github.com/yesodweb/yesod/issues/1389)
-To configure this new functionality:
-  1. Define `addUnverifiedWithPass`, e.g:
-  ```
-  addUnverified email verkey = liftHandler $ runDB $ do
-    void $ insert $ UserLogin email Nothing (Just verkey) False
-    return email
-
-  addUnverifiedWithPass email verkey pass = liftHandler $ runDB $ do
-    void $ insert $ UserLogin email (Just pass) (Just verkey) False
-    return email
-  ```
-  2. Add a `password` field to your client forms.
-
-## 1.6.3
-
-* Generalize GoogleEmail2.getPerson [#1501](https://github.com/yesodweb/yesod/pull/1501)
-
-## 1.6.2
-
-* Remove MINIMAL praggma for authHttpManager [#1489](https://github.com/yesodweb/yesod/issues/1489)
-
-## 1.6.1
-
-* Relax a number of type signatures [#1488](https://github.com/yesodweb/yesod/issues/1488)
-
-## 1.6.0
-
-* Upgrade to yesod-core 1.6.0
-
 ## 1.4.21
 
 * Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin [#1461](https://github.com/yesodweb/yesod/pull/1461)

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
@@ -38,7 +39,6 @@ module Yesod.Auth
       -- * Exception
     , AuthException (..)
       -- * Helper
-    , MonadAuthHandler
     , AuthHandler
       -- * Internal
     , credsKey
@@ -47,11 +47,12 @@ module Yesod.Auth
     , asHtml
     ) where
 
+import           Control.Applicative ((<$>))
 import Control.Monad                 (when)
 import Control.Monad.Trans.Maybe
-import UnliftIO                      (withRunInIO, MonadUnliftIO)
 
 import Yesod.Auth.Routes
+import Data.Aeson hiding (json)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
 import           Data.Text (Text)
@@ -59,11 +60,11 @@ import qualified Data.Text as T
 import qualified Data.HashMap.Lazy as Map
 import Data.Monoid (Endo)
 import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader)
-import Network.HTTP.Client.TLS (getGlobalManager)
 
 import qualified Network.Wai as W
 
 import Yesod.Core
+import Yesod.Core.Types (HandlerT(..), unHandlerT)
 import Yesod.Persist
 import Yesod.Auth.Message (AuthMessage, defaultMessage)
 import qualified Yesod.Auth.Message as Msg
@@ -71,21 +72,20 @@ import Yesod.Form (FormMessage)
 import Data.Typeable (Typeable)
 import Control.Exception (Exception)
 import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
+import Control.Monad.Trans.Resource (MonadResourceBase)
 import qualified Control.Monad.Trans.Writer    as Writer
 import Control.Monad (void)
-import Data.Kind (Type)
 
 type AuthRoute = Route Auth
 
-type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
+type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a
-type AuthHandler master a = forall m. MonadAuthHandler master m => m a
 
 type Method = Text
 type Piece = Text
 
 -- | The result of an authentication based on credentials
 --
--- @since 1.4.4
+-- Since 1.4.4
 data AuthenticationResult master
     = Authenticated (AuthId master) -- ^ Authenticated successfully
     | UserError AuthMessage         -- ^ Invalid credentials provided by user
@@ -94,7 +94,7 @@ data AuthenticationResult master
 data AuthPlugin master = AuthPlugin
     { apName :: Text
     , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
-    , apLogin :: (Route Auth -> Route master) -> WidgetFor master ()
+    , apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
     }
 
 getAuth :: a -> Auth
@@ -111,8 +111,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     type AuthId master
 
     -- | specify the layout. Uses defaultLayout by default
-    authLayout :: (MonadHandler m, HandlerSite m ~ master) => WidgetFor master () -> m Html
+    authLayout :: WidgetT master IO () -> HandlerT master IO Html
-    authLayout = liftHandler . defaultLayout
+    authLayout = defaultLayout
 
     -- | Default destination on successful login, if no other
     -- destination exists.
@@ -126,8 +126,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     --
     -- Default implementation is in terms of @'getAuthId'@
     --
-    -- @since: 1.4.4
+    -- Since: 1.4.4
-    authenticate :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (AuthenticationResult master)
+    authenticate :: Creds master -> HandlerT master IO (AuthenticationResult master)
     authenticate creds = do
         muid <- getAuthId creds
 
@@ -137,7 +137,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     --
     -- Default implementation is in terms of @'authenticate'@
     --
-    getAuthId :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (Maybe (AuthId master))
+    getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master))
     getAuthId creds = do
         auth <- authenticate creds
 
@@ -167,7 +167,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- >             lift $ redirect HomeR   -- or any other Handler code you want
     -- >         defaultLoginHandler
     --
-    loginHandler :: AuthHandler master Html
+    loginHandler :: HandlerT Auth (HandlerT master IO) Html
     loginHandler = defaultLoginHandler
 
     -- | Used for i18n of messages provided by this package.
@@ -184,8 +184,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
 
     -- | When being redirected to the login page should the current page
     -- be set to redirect back to. Default is 'True'.
-    --
+    -- @since 1.4.18
-    -- @since 1.4.21
     redirectToCurrent :: master -> Bool
     redirectToCurrent _ = True
 
@@ -193,16 +192,15 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- type. This allows backends to reuse persistent connections. If none of
     -- the backends you're using use HTTP connections, you can safely return
     -- @error \"authHttpManager\"@ here.
-    authHttpManager :: (MonadHandler m, HandlerSite m ~ master) => m Manager
+    authHttpManager :: master -> Manager
-    authHttpManager = liftIO getGlobalManager
 
     -- | Called on a successful login. By default, calls
     -- @addMessageI "success" NowLoggedIn@.
-    onLogin :: (MonadHandler m, master ~ HandlerSite m) => m ()
+    onLogin :: HandlerT master IO ()
     onLogin = addMessageI "success" Msg.NowLoggedIn
 
     -- | Called on logout. By default, does nothing
-    onLogout :: (MonadHandler m, master ~ HandlerSite m) => m ()
+    onLogout :: HandlerT master IO ()
     onLogout = return ()
 
     -- | Retrieves user credentials, if user is authenticated.
@@ -213,17 +211,17 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- especially useful for creating an API to be accessed via some means
     -- other than a browser.
     --
-    -- @since 1.2.0
+    -- Since 1.2.0
-    maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master))
+    maybeAuthId :: HandlerT master IO (Maybe (AuthId master))
 
     default maybeAuthId
-        :: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master))
+        :: (YesodAuthPersist master, Typeable (AuthEntity master))
-        => m (Maybe (AuthId master))
+        => HandlerT master IO (Maybe (AuthId master))
     maybeAuthId = defaultMaybeAuthId
 
     -- | Called on login error for HTTP requests. By default, calls
     -- @addMessage@ with "error" as status and redirects to @dest@.
-    onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html
+    onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html
     onErrorHtml dest msg = do
         addMessage "error" $ toHtml msg
         fmap asHtml $ redirect dest
@@ -233,22 +231,18 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     --
     --  The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request.
     --  This is an experimental API that is not broadly used throughout the yesod-auth code base
-    runHttpRequest
+    runHttpRequest :: Request -> (Response BodyReader -> HandlerT master IO a) -> HandlerT master IO a
-      :: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m)
-      => Request
-      -> (Response BodyReader -> m a)
-      -> m a
     runHttpRequest req inner = do
-      man <- authHttpManager
+      man <- authHttpManager Control.Applicative.<$> getYesod
-      withRunInIO $ \run -> withResponse req man $ run . inner
+      HandlerT $ \t -> withResponse req man $ \res -> unHandlerT (inner res) t
 
-    {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins #-}
+    {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-}
 
 {-# DEPRECATED getAuthId "Define 'authenticate' instead; 'getAuthId' will be removed in the next major version" #-}
 
 -- | Internal session key used to hold the authentication information.
 --
--- @since 1.2.3
+-- Since 1.2.3
 credsKey :: Text
 credsKey = "_ID"
 
@@ -258,10 +252,10 @@ credsKey = "_ID"
 -- 'maybeAuthIdRaw' for more information. The first call in a request
 -- does a database request to make sure that the account is still in the database.
 --
--- @since 1.1.2
+-- Since 1.1.2
 defaultMaybeAuthId
-    :: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master))
+    :: (YesodAuthPersist master, Typeable (AuthEntity master))
-    => m (Maybe (AuthId master))
+    => HandlerT master IO (Maybe (AuthId master))
 defaultMaybeAuthId = runMaybeT $ do
     s   <- MaybeT $ lookupSession credsKey
     aid <- MaybeT $ return $ fromPathPiece s
@@ -269,13 +263,8 @@ defaultMaybeAuthId = runMaybeT $ do
     return aid
 
 cachedAuth
-    :: ( MonadHandler m
+    :: (YesodAuthPersist master, Typeable (AuthEntity master))
-       , YesodAuthPersist master
+    => AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
-       , Typeable (AuthEntity master)
-       , HandlerSite m ~ master
-       )
-    => AuthId master
-    -> m (Maybe (AuthEntity master))
 cachedAuth
     = fmap unCachedMaybeAuth
     . cached
@@ -288,59 +277,52 @@ cachedAuth
 -- This is the default 'loginHandler'.  It concatenates plugin widgets and
 -- wraps the result in 'authLayout'.  See 'loginHandler' for more details.
 --
--- @since 1.4.9
+-- Since 1.4.9
 defaultLoginHandler :: AuthHandler master Html
 defaultLoginHandler = do
     tp <- getRouteToParent
-    authLayout $ do
+    lift $ authLayout $ do
         setTitleI Msg.LoginTitle
         master <- getYesod
         mapM_ (flip apLogin tp) (authPlugins master)
 
 
-loginErrorMessageI
+loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)
-  :: Route Auth
+                   => Route child
-  -> AuthMessage
+                   -> AuthMessage
-  -> AuthHandler master TypedContent
+                   -> HandlerT child (HandlerT master m) TypedContent
 loginErrorMessageI dest msg = do
   toParent <- getRouteToParent
-  loginErrorMessageMasterI (toParent dest) msg
+  lift $ loginErrorMessageMasterI (toParent dest) msg
 
 
-loginErrorMessageMasterI
+loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)
-  :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)
+         => Route master
-  => Route master
+         -> AuthMessage
-  -> AuthMessage
+         -> HandlerT master m TypedContent
-  -> m TypedContent
 loginErrorMessageMasterI dest msg = do
   mr <- getMessageRender
   loginErrorMessage dest (mr msg)
 
 -- | For HTML, set the message and redirect to the route.
 -- For JSON, send the message and a 401 status
-loginErrorMessage
+loginErrorMessage :: (YesodAuth master, MonadResourceBase m)
-         :: (MonadHandler m, YesodAuth (HandlerSite m))
+         => Route master
-         => Route (HandlerSite m)
          -> Text
-         -> m TypedContent
+         -> HandlerT master m TypedContent
 loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
 
-messageJson401
+messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
-  :: MonadHandler m
-  => Text
-  -> m Html
-  -> m TypedContent
 messageJson401 = messageJsonStatus unauthorized401
 
-messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent
+messageJson500 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
 messageJson500 = messageJsonStatus internalServerError500
 
-messageJsonStatus
+messageJsonStatus :: MonadResourceBase m
-  :: MonadHandler m
+                  => Status
-  => Status
+                  -> Text
-  -> Text
+                  -> HandlerT master m Html
-  -> m Html
+                  -> HandlerT master m TypedContent
-  -> m TypedContent
 messageJsonStatus status msg html = selectRep $ do
     provideRep html
     provideRep $ do
@@ -352,10 +334,9 @@ provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
 provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
 
 
-setCredsRedirect
+setCredsRedirect :: YesodAuth master
-  :: (MonadHandler m, YesodAuth (HandlerSite m))
+         => Creds master -- ^ new credentials
-  => Creds (HandlerSite m) -- ^ new credentials
+         -> HandlerT master IO TypedContent
-  -> m TypedContent
 setCredsRedirect creds = do
     y    <- getYesod
     auth <- authenticate creds
@@ -394,10 +375,10 @@ setCredsRedirect creds = do
         return $ renderAuthMessage master langs msg
 
 -- | Sets user credentials for the session after checking them with authentication backends.
-setCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
+setCreds :: YesodAuth master
-         => Bool                  -- ^ if HTTP redirects should be done
+         => Bool         -- ^ if HTTP redirects should be done
-         -> Creds (HandlerSite m) -- ^ new credentials
+         -> Creds master -- ^ new credentials
-         -> m ()
+         -> HandlerT master IO ()
 setCreds doRedirects creds =
     if doRedirects
       then void $ setCredsRedirect creds
@@ -407,36 +388,29 @@ setCreds doRedirects creds =
                   _ -> return ()
 
 -- | same as defaultLayoutJson, but uses authLayout
-authLayoutJson
+authLayoutJson :: (YesodAuth site, ToJSON j)
-  :: (ToJSON j, MonadAuthHandler master m)
+                  => WidgetT site IO ()  -- ^ HTML
-  => WidgetFor master ()  -- ^ HTML
+                  -> HandlerT site IO j  -- ^ JSON
-  -> m j  -- ^ JSON
+                  -> HandlerT site IO TypedContent
-  -> m TypedContent
 authLayoutJson w json = selectRep $ do
     provideRep $ authLayout w
     provideRep $ fmap toJSON json
 
 -- | Clears current user credentials for the session.
 --
--- @since 1.1.7
+-- Since 1.1.7
-clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
+clearCreds :: YesodAuth master
-           => Bool -- ^ if HTTP, redirect to 'logoutDest'
+           => Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-           -> m ()
+           -> HandlerT master IO ()
 clearCreds doRedirects = do
+    y <- getYesod
     onLogout
     deleteSession credsKey
-    y  <- getYesod
+    when doRedirects $ do
-    aj <- acceptsJson
+        redirectUltDest $ logoutDest y
-    case (aj, doRedirects) of
-      (True, _)               -> sendResponse successfulLogout
-      (False, True)           -> redirectUltDest (logoutDest y)
-      _                       -> return ()
-    where successfulLogout = object ["message" .= msg]
-          msg :: Text
-          msg = "Logged out successfully!"
 
 getCheckR :: AuthHandler master TypedContent
-getCheckR = do
+getCheckR = lift $ do
     creds <- maybeAuthId
     authLayoutJson (do
         setTitle "Authentication Status"
@@ -452,12 +426,12 @@ $nothing
     <p>Not logged in.
 |]
     jsonCreds creds =
-        toJSON $ Map.fromList
+        Object $ Map.fromList
             [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
             ]
 
-setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m ()
+setUltDestReferer' :: AuthHandler master ()
-setUltDestReferer' = do
+setUltDestReferer' = lift $ do
     master <- getYesod
     when (redirectToReferer master) setUltDestReferer
 
@@ -465,16 +439,14 @@ getLoginR :: AuthHandler master Html
 getLoginR = setUltDestReferer' >> loginHandler
 
 getLogoutR :: AuthHandler master ()
-getLogoutR = do
+getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
-  tp <- getRouteToParent
-  setUltDestReferer' >> redirectToPost (tp LogoutR)
 
 postLogoutR :: AuthHandler master ()
-postLogoutR = clearCreds True
+postLogoutR = lift $ clearCreds True
 
 handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
 handlePluginR plugin pieces = do
-    master <- getYesod
+    master <- lift getYesod
     env <- waiRequest
     let method = decodeUtf8With lenientDecode $ W.requestMethod env
     case filter (\x -> apName x == plugin) (authPlugins master) of
@@ -485,28 +457,23 @@ handlePluginR plugin pieces = do
 -- with the user\'s database identifier to get the value in the database. This
 -- assumes that you are using a Persistent database.
 --
--- @since 1.1.0
+-- Since 1.1.0
 maybeAuth :: ( YesodAuthPersist master
              , val ~ AuthEntity master
              , Key val ~ AuthId master
              , PersistEntity val
              , Typeable val
-             , MonadHandler m
+             ) => HandlerT master IO (Maybe (Entity val))
-             , HandlerSite m ~ master
+maybeAuth = runMaybeT $ do
-             ) => m (Maybe (Entity val))
+    (aid, ae) <- MaybeT maybeAuthPair
-maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
+    return $ Entity aid ae
 
 -- | Similar to 'maybeAuth', but doesn’t assume that you are using a
 -- Persistent database.
 --
--- @since 1.4.0
+-- Since 1.4.0
-maybeAuthPair
+maybeAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
-  :: ( YesodAuthPersist master
+              => HandlerT master IO (Maybe (AuthId master, AuthEntity master))
-     , Typeable (AuthEntity master)
-     , MonadHandler m
-     , HandlerSite m ~ master
-     )
-  => m (Maybe (AuthId master, AuthEntity master))
 maybeAuthPair = runMaybeT $ do
     aid <- MaybeT maybeAuthId
     ae  <- MaybeT $ cachedAuth aid
@@ -514,6 +481,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
@@ -524,7 +492,7 @@ newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
 -- given value.  This is the common case in Yesod, and means that you can
 -- easily look up the full information on a given user.
 --
--- @since 1.4.0
+-- Since 1.4.0
 class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
     -- | If the @AuthId@ for a given site is a persistent ID, this will give the
     -- value for that entity. E.g.:
@@ -532,23 +500,31 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
     -- > type AuthId MySite = UserId
     -- > AuthEntity MySite ~ User
     --
-    -- @since 1.2.0
+    -- Since 1.2.0
-    type AuthEntity master :: Type
+    type AuthEntity master :: *
     type AuthEntity master = KeyEntity (AuthId master)
 
-    getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)
+    getAuthEntity :: AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
-                  => AuthId master -> m (Maybe (AuthEntity master))
 
+#if MIN_VERSION_persistent(2,5,0)
     default getAuthEntity
         :: ( YesodPersistBackend master ~ backend
            , PersistRecordBackend (AuthEntity master) backend
            , Key (AuthEntity master) ~ AuthId master
            , PersistStore backend
-           , MonadHandler m
-           , HandlerSite m ~ master
            )
-        => AuthId master -> m (Maybe (AuthEntity master))
+        => AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
-    getAuthEntity = liftHandler . runDB . get
+#else
+    default getAuthEntity
+        :: ( YesodPersistBackend master
+               ~ PersistEntityBackend (AuthEntity master)
+           , Key (AuthEntity master) ~ AuthId master
+           , PersistStore (YesodPersistBackend master)
+           , PersistEntity (AuthEntity master)
+           )
+        => AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
+#endif
+    getAuthEntity = runDB . get
 
 
 type family KeyEntity key
@@ -557,43 +533,36 @@ type instance KeyEntity (Key x) = x
 -- | Similar to 'maybeAuthId', but redirects to a login page if user is not
 -- authenticated or responds with error 401 if this is an API client (expecting JSON).
 --
--- @since 1.1.0
+-- Since 1.1.0
-requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m))
+requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master)
 requireAuthId = maybeAuthId >>= maybe handleAuthLack return
 
 -- | Similar to 'maybeAuth', but redirects to a login page if user is not
 -- authenticated or responds with error 401 if this is an API client (expecting JSON).
 --
--- @since 1.1.0
+-- Since 1.1.0
 requireAuth :: ( YesodAuthPersist master
                , val ~ AuthEntity master
                , Key val ~ AuthId master
                , PersistEntity val
                , Typeable val
-               , MonadHandler m
+               ) => HandlerT master IO (Entity val)
-               , HandlerSite m ~ master
-               ) => m (Entity val)
 requireAuth = maybeAuth >>= maybe handleAuthLack return
 
 -- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
 -- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple.
 --
--- @since 1.4.0
+-- Since 1.4.0
-requireAuthPair
+requireAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
-  :: ( YesodAuthPersist master
+                => HandlerT master IO (AuthId master, AuthEntity master)
-     , Typeable (AuthEntity master)
-     , MonadHandler m
-     , HandlerSite m ~ master
-     )
-  => m (AuthId master, AuthEntity master)
 requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return
 
-handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
+handleAuthLack :: YesodAuth master => HandlerT master IO a
 handleAuthLack = do
     aj <- acceptsJson
     if aj then notAuthenticated else redirectLogin
 
-redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
+redirectLogin :: YesodAuth master => HandlerT master IO a
 redirectLogin = do
     y <- getYesod
     when (redirectToCurrent y) setUltDestCurrent
@@ -605,10 +574,10 @@ 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
+instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
     yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
 
 asHtml :: Html -> Html

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -70,21 +70,20 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
     , apDispatch = \m ps ->
         case (m, ps) of
             ("GET", [assertion]) -> do
+                master <- lift getYesod
                 audience <-
                     case bisAudience of
                         Just a -> return a
                         Nothing -> do
                             r <- getUrlRender
-                            tm <- getRouteToParent
+                            return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR
-                            return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
+                memail <- lift $ checkAssertion audience assertion (authHttpManager master)
-                manager <- authHttpManager
-                memail <- checkAssertion audience assertion manager
                 case memail of
                     Nothing -> do
                       $logErrorS "yesod-auth" "BrowserID assertion failure"
                       tm <- getRouteToParent
-                      loginErrorMessage (tm LoginR) "BrowserID login error."
+                      lift $ loginErrorMessage (tm LoginR) "BrowserID login error."
-                    Just email -> setCredsRedirect Creds
+                    Just email -> lift $ setCredsRedirect Creds
                         { credsPlugin = pid
                         , credsIdent = email
                         , credsExtra = []
@@ -117,7 +116,7 @@ $newline never
 createOnClickOverride :: BrowserIdSettings
               -> (Route Auth -> Route master)
               -> Maybe (Route master)
-              -> WidgetFor master Text
+              -> WidgetT master IO Text
 createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
     unless bisLazyLoad $ addScriptRemote browserIdJs
     onclick <- newIdent
@@ -166,5 +165,5 @@ createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
 -- name.
 createOnClick :: BrowserIdSettings
               -> (Route Auth -> Route master)
-              -> WidgetFor master Text
+              -> WidgetT master IO Text
 createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing

yesod-auth/Yesod/Auth/Dummy.hs

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

yesod-auth/Yesod/Auth/Email.hs

@@ -31,27 +31,24 @@
 -- = Using JSON Endpoints
 --
 -- We are assuming that you have declared auth route as follows
---
+-- 
 -- @
 --    /auth AuthR Auth getAuth
 -- @
---
+-- 
 -- If you are using a different route, then you have to adjust the
 -- endpoints accordingly.
 --
 --     * Registration
---
+-- 
 -- @
 --       Endpoint: \/auth\/page\/email\/register
 --       Method: POST
---       JSON Data: {
+--       JSON Data: { "email": "myemail@domain.com" }
---                      "email": "myemail@domain.com",
---                      "password": "myStrongPassword" (optional)
---                  }
 -- @
---
+-- 
 --     * Forgot password
---
+--  
 -- @
 --       Endpoint: \/auth\/page\/email\/forgot-password
 --       Method: POST
@@ -59,16 +56,16 @@
 -- @
 --
 --     * Login
---
+--  
 -- @
 --       Endpoint: \/auth\/page\/email\/login
 --       Method: POST
---       JSON Data: {
+--       JSON Data: { 
 --                      "email": "myemail@domain.com",
 --                      "password": "myStrongPassword"
 --                  }
 -- @
---
+-- 
 --     * Set new password
 --
 -- @
@@ -113,34 +110,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.Message       as Msg
-import qualified Yesod.Auth.Util.PasswordStore as PS
 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"]
@@ -148,15 +141,11 @@ registerR = PluginR "email" ["register"]
 forgotPasswordR = PluginR "email" ["forgot-password"]
 setpassR = PluginR "email" ["set-password"]
 
-verifyURLHasSetPassText :: Text
-verifyURLHasSetPassText = "has-set-pass"
-
 -- |
 --
 -- @since 1.4.5
-verifyR :: Text -> Text -> Bool -> AuthRoute -- FIXME
+verifyR :: Text -> Text -> AuthRoute -- FIXME
-verifyR eid verkey hasSetPass = PluginR "email" path
+verifyR eid verkey = PluginR "email" ["verify", eid, verkey]
-    where path = "verify":eid:verkey:(if hasSetPass then [verifyURLHasSetPassText] else [])
 
 type Email = Text
 type VerKey = Text
@@ -197,59 +186,37 @@ class ( YesodAuth site
     -- has not yet been verified.
     --
     -- @since 1.1.0
-    addUnverified :: Email -> VerKey -> AuthHandler site (AuthEmailId site)
+    addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site)
-
-    -- | Similar to `addUnverified`, but comes with the registered password.
-    --
-    -- The default implementation is just `addUnverified`, which ignores the password.
-    --
-    -- You may override this to save the salted password to your database.
-    --
-    -- @since 1.6.4
-    addUnverifiedWithPass :: Email -> VerKey -> SaltedPass -> AuthHandler site (AuthEmailId site)
-    addUnverifiedWithPass email verkey _ = addUnverified email verkey
 
     -- | Send an email to the given address to verify ownership.
     --
     -- @since 1.1.0
-    sendVerifyEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()
+    sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO ()
-
-    -- | 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
-    getVerifyKey :: AuthEmailId site -> AuthHandler site (Maybe VerKey)
+    getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey)
 
     -- | Set the verification key for the given email ID.
     --
     -- @since 1.1.0
-    setVerifyKey :: AuthEmailId site -> VerKey -> AuthHandler site ()
+    setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO ()
 
     -- | Hash and salt a password
     --
     -- Default: 'saltPass'.
     --
     -- @since 1.4.20
-    hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
+    hashAndSaltPassword :: Text -> HandlerT site IO SaltedPass
-    hashAndSaltPassword password = liftIO $ saltPass password
+    hashAndSaltPassword = liftIO . saltPass
 
     -- | Verify a password matches the stored password for the given account.
     --
     -- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'.
     --
     -- @since 1.4.20
-    verifyPassword :: Text -> SaltedPass -> AuthHandler site Bool
+    verifyPassword :: Text -> SaltedPass -> HandlerT site IO Bool
     verifyPassword plain salted = return $ isValidPass plain salted
 
     -- | Verify the email address on the given account.
@@ -261,28 +228,28 @@ class ( YesodAuth site
     -- See <https://github.com/yesodweb/yesod/issues/1222>.
     --
     -- @since 1.1.0
-    verifyAccount :: AuthEmailId site -> AuthHandler site (Maybe (AuthId site))
+    verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site))
 
     -- | Get the salted password for the given account.
     --
     -- @since 1.1.0
-    getPassword :: AuthId site -> AuthHandler site (Maybe SaltedPass)
+    getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass)
 
     -- | Set the salted password for the given account.
     --
     -- @since 1.1.0
-    setPassword :: AuthId site -> SaltedPass -> AuthHandler site ()
+    setPassword :: AuthId site -> SaltedPass -> HandlerT site IO ()
 
     -- | Get the credentials for the given @Identifier@, which may be either an
     -- email address or some other identification (e.g., username).
     --
     -- @since 1.2.0
-    getEmailCreds :: Identifier -> AuthHandler site (Maybe (EmailCreds site))
+    getEmailCreds :: Identifier -> HandlerT site IO (Maybe (EmailCreds site))
 
     -- | Get the email address for the given email ID.
     --
     -- @since 1.1.0
-    getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email)
+    getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email)
 
     -- | Generate a random alphanumeric string.
     --
@@ -295,19 +262,13 @@ class ( YesodAuth site
     -- @since 1.2.0
     afterPasswordRoute :: site -> Route site
 
-    -- | Route to send user to after verification with a password
-    --
-    -- @since 1.6.4
-    afterVerificationWithPass :: site -> Route site
-    afterVerificationWithPass = afterPasswordRoute
-
     -- | Does the user need to provide the current password in order to set a
     -- new password?
     --
     -- Default: if the user logged in via an email link do not require a password.
     --
     -- @since 1.2.1
-    needOldPassword :: AuthId site -> AuthHandler site Bool
+    needOldPassword :: AuthId site -> HandlerT site IO Bool
     needOldPassword aid' = do
         mkey <- lookupSession loginLinkKey
         case mkey >>= readMay . TS.unpack of
@@ -319,7 +280,7 @@ class ( YesodAuth site
     -- | Check that the given plain-text password meets minimum security standards.
     --
     -- Default: password is at least three characters.
-    checkPasswordSecurity :: AuthId site -> Text -> AuthHandler site (Either Text ())
+    checkPasswordSecurity :: AuthId site -> Text -> HandlerT site IO (Either Text ())
     checkPasswordSecurity _ x
         | TS.length x >= 3 = return $ Right ()
         | otherwise = return $ Left "Password must be at least three characters"
@@ -327,7 +288,7 @@ class ( YesodAuth site
     -- | Response after sending a confirmation email.
     --
     -- @since 1.2.2
-    confirmationEmailSentResponse :: Text -> AuthHandler site TypedContent
+    confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent
     confirmationEmailSentResponse identifier = do
         mr <- getMessageRender
         selectRep $ do
@@ -338,14 +299,6 @@ class ( YesodAuth site
       where
         msg = Msg.ConfirmationEmailSent identifier
 
-    -- | If a response is set, it will be used when an already-verified email
-    -- tries to re-register. Otherwise, `confirmationEmailSentResponse` will be
-    -- used.
-    --
-    -- @since 1.6.4
-    emailPreviouslyRegisteredResponse :: MonadAuthHandler site m => Text -> Maybe (m TypedContent)
-    emailPreviouslyRegisteredResponse _ = Nothing
-
     -- | Additional normalization of email addresses, besides standard canonicalization.
     --
     -- Default: Lower case the email address.
@@ -361,7 +314,7 @@ class ( YesodAuth site
     -- Default: 'defaultEmailLoginHandler'.
     --
     -- @since 1.4.17
-    emailLoginHandler :: (Route Auth -> Route site) -> WidgetFor site ()
+    emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO ()
     emailLoginHandler = defaultEmailLoginHandler
 
 
@@ -372,7 +325,7 @@ class ( YesodAuth site
     -- Default: 'defaultRegisterHandler'.
     --
     -- @since: 1.2.6
-    registerHandler :: AuthHandler site Html
+    registerHandler :: HandlerT Auth (HandlerT site IO) Html
     registerHandler = defaultRegisterHandler
 
     -- | Handler called to render the \"forgot password\" page.
@@ -382,7 +335,7 @@ class ( YesodAuth site
     -- Default: 'defaultForgotPasswordHandler'.
     --
     -- @since: 1.2.6
-    forgotPasswordHandler :: AuthHandler site Html
+    forgotPasswordHandler :: HandlerT Auth (HandlerT site IO) Html
     forgotPasswordHandler = defaultForgotPasswordHandler
 
     -- | Handler called to render the \"set password\" page.  The
@@ -398,75 +351,38 @@ class ( YesodAuth site
          -- field for the old password should be presented.
          -- Otherwise, just two fields for the new password are
          -- needed.
-      -> AuthHandler site TypedContent
+      -> HandlerT Auth (HandlerT site IO) TypedContent
     setPasswordHandler = defaultSetPasswordHandler
 
-
-    -- | Helper that controls what happens after a user registration
-    -- request is submitted. This method can be overridden to completely
-    -- customize what happens during the user registration process,
-    -- such as for handling additional fields in the registration form.
-    --
-    -- The default implementation is in terms of 'defaultRegisterHelper'.
-    --
-    -- @since: 1.6.9
-    registerHelper :: Route Auth
-                      -- ^ Where to sent the user in the event
-                      -- that registration fails
-                   -> AuthHandler site TypedContent
-    registerHelper = defaultRegisterHelper False False
-
-    -- | Helper that controls what happens after a forgot password
-    -- request is submitted. As with `registerHelper`, this method can
-    -- be overridden to customize the behavior when a user attempts
-    -- to recover their password.
-    --
-    -- The default implementation is in terms of 'defaultRegisterHelper'.
-    --
-    -- @since: 1.6.9
-    passwordResetHelper :: Route Auth
-                           -- ^ Where to sent the user in the event
-                           -- that the password reset fails
-                        -> AuthHandler site TypedContent
-    passwordResetHelper = defaultRegisterHelper True True
-
 authEmail :: (YesodAuthEmail m) => AuthPlugin m
 authEmail =
     AuthPlugin "email" dispatch emailLoginHandler
   where
-    dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent
     dispatch "GET" ["register"] = getRegisterR >>= sendResponse
     dispatch "POST" ["register"] = postRegisterR >>= sendResponse
     dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse
     dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse
     dispatch "GET" ["verify", eid, verkey] =
-        case fromPathPiece eid of
-            Nothing   -> notFound
-            Just eid' -> getVerifyR eid' verkey False >>= sendResponse
-    dispatch "GET" ["verify", eid, verkey, hasSetPass] =
         case fromPathPiece eid of
             Nothing -> notFound
-            Just eid' -> getVerifyR eid' verkey (hasSetPass == verifyURLHasSetPassText) >>= sendResponse
+            Just eid' -> getVerifyR eid' verkey >>= sendResponse
     dispatch "POST" ["login"] = postLoginR >>= sendResponse
     dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse
     dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse
     dispatch _ _ = notFound
 
-getRegisterR :: YesodAuthEmail master => AuthHandler master Html
+getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
 getRegisterR = registerHandler
 
 -- | Default implementation of 'emailLoginHandler'.
 --
 -- @since 1.4.17
-defaultEmailLoginHandler
+defaultEmailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO ()
-  :: YesodAuthEmail master
-  => (Route Auth -> Route master)
-  -> WidgetFor master ()
 defaultEmailLoginHandler toParent = do
-        (widget, enctype) <- generateFormPost loginForm
+        (widget, enctype) <- liftWidgetT $ generateFormPost loginForm
 
         [whamlet|
-            <form method="post" action="@{toParent loginR}" enctype=#{enctype}>
+            <form method="post" action="@{toParent loginR}", enctype=#{enctype}>
                 <div id="emailLoginForm">
                     ^{widget}
                     <div>
@@ -488,13 +404,13 @@ defaultEmailLoginHandler toParent = do
         let userRes = UserLoginForm Control.Applicative.<$> emailRes
                                     Control.Applicative.<*> passwordRes
         let widget = do
-              [whamlet|
+            [whamlet|
-                  #{extra}
+                #{extra}
-                  <div>
+                <div>
-                      ^{fvInput emailView}
+                    ^{fvInput emailView}
-                  <div>
+                <div>
-                      ^{fvInput passwordView}
+                    ^{fvInput passwordView}
-              |]
+            |]
 
         return (userRes, widget)
     emailSettings emailMsg = do
@@ -521,11 +437,11 @@ defaultEmailLoginHandler toParent = do
 -- | Default implementation of 'registerHandler'.
 --
 -- @since 1.2.6
-defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
+defaultRegisterHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
 defaultRegisterHandler = do
-    (widget, enctype) <- generateFormPost registrationForm
+    (widget, enctype) <- lift $ generateFormPost registrationForm
     toParentRoute <- getRouteToParent
-    authLayout $ do
+    lift $ authLayout $ do
         setTitleI Msg.RegisterLong
         [whamlet|
             <p>_{Msg.EnterEmail}
@@ -548,106 +464,81 @@ defaultRegisterHandler = do
 
             let userRes = UserForm <$> emailRes
             let widget = do
-                  [whamlet|
+                [whamlet|
-                      #{extra}
+                    #{extra}
-                      ^{fvLabel emailView}
+                    ^{fvLabel emailView}
-                      ^{fvInput emailView}
+                    ^{fvInput emailView}
-                  |]
+                |]
 
             return (userRes, widget)
 
-parseRegister :: Value -> Parser (Text, Maybe Text)
+parseEmail :: Value -> Parser Text
-parseRegister = withObject "email" (\obj -> do
+parseEmail = withObject "email" (\obj -> do
-                                      email <- obj .: "email"
+                                   email' <- obj .: "email"
-                                      pass <- obj .:? "password"
+                                   return email')
-                                      return (email, pass))
 
-defaultRegisterHelper :: YesodAuthEmail master
+registerHelper :: YesodAuthEmail master
-                      => Bool -- ^ Allow lookup via username in addition to email
+               => Bool -- ^ allow usernames?
-                      -> Bool -- ^ Set to `True` for forgot password flow, `False` for new account registration
+               -> Route Auth
-                      -> Route Auth
+               -> HandlerT Auth (HandlerT master IO) TypedContent
-                      -> AuthHandler master TypedContent
+registerHelper allowUsername dest = do
-defaultRegisterHelper allowUsername forgotPassword dest = do
+    y <- lift getYesod
-    y <- getYesod
     checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
-    result <- runInputPostResult $ (,)
+    pidentifier <- lookupPostParam "email"
-        <$> ireq textField "email"
+    midentifier <- case pidentifier of
-        <*> iopt textField "password"
+                     Nothing -> do
-
+                       (jidentifier :: Result Value) <- lift parseCheckJsonBody
-    creds <- case result of
+                       case jidentifier of
-                 FormSuccess (iden, pass) -> return $ Just (iden, pass)
+                         Error _ -> return Nothing
-                 _ -> do
+                         Success val -> return $ parseMaybe parseEmail val
-                     (creds :: Result Value) <- parseCheckJsonBody
+                     Just _ -> return pidentifier
-                     return $ case creds of
+    let eidentifier = case midentifier of
-                                  Error _     -> Nothing
-                                  Success val -> parseMaybe parseRegister val
-
-    let eidentifier = case creds of
                           Nothing -> Left Msg.NoIdentifierProvided
-                          Just (x, _)
+                          Just x
                               | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->
                                          Right $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'
                               | allowUsername -> Right $ TS.strip x
                               | otherwise -> Left Msg.InvalidEmailAddress
-
-    let mpass = case (forgotPassword, creds) of
-                    (False, Just (_, mp)) -> mp
-                    _                     -> Nothing
-
     case eidentifier of
-      Left failMsg -> loginErrorMessageI dest failMsg
+      Left route -> loginErrorMessageI dest route
       Right identifier -> do
-            mecreds <- getEmailCreds identifier
+            mecreds <- lift $ getEmailCreds identifier
             registerCreds <-
                 case mecreds of
-                    Just (EmailCreds lid _ verStatus (Just key) email) -> return $ Just (lid, verStatus, key, email)
+                    Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
-                    Just (EmailCreds lid _ verStatus Nothing email) -> do
+                    Just (EmailCreds lid _ _ Nothing email) -> do
                         key <- liftIO $ randomKey y
-                        setVerifyKey lid key
+                        lift $ setVerifyKey lid key
-                        return $ Just (lid, verStatus, key, email)
+                        return $ Just (lid, key, email)
                     Nothing
                         | allowUsername -> return Nothing
                         | otherwise -> do
                             key <- liftIO $ randomKey y
-                            lid <- case mpass of
+                            lid <- lift $ addUnverified identifier key
-                                Just pass -> do
+                            return $ Just (lid, key, identifier)
-                                    salted <- hashAndSaltPassword pass
+
-                                    addUnverifiedWithPass identifier key salted
-                                _ -> addUnverified identifier key
-                            return $ Just (lid, False, key, identifier)
             case registerCreds of
                 Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
-                Just creds@(_, False, _, _) -> sendConfirmationEmail creds
+                Just (lid, verKey, email) -> do
-                Just creds@(_, True, _, _) -> do
+                    render <- getUrlRender
-                  if forgotPassword
+                    let verUrl = render $ verifyR (toPathPiece lid) verKey
-                    then sendConfirmationEmail creds
+                    lift $ sendVerifyEmail email verKey verUrl
-                    else case emailPreviouslyRegisteredResponse identifier of
+                    lift $ confirmationEmailSentResponse identifier
-                      Just response -> response
-                      Nothing       -> sendConfirmationEmail creds
-              where sendConfirmationEmail (lid, _, verKey, email) = do
-                      render <- getUrlRender
-                      tp <- getRouteToParent
-                      let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey (isJust mpass)
-                      if forgotPassword
-                         then sendForgotPasswordEmail email verKey verUrl
-                         else sendVerifyEmail email verKey verUrl
-                      confirmationEmailSentResponse identifier
 
+postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
+postRegisterR = registerHelper False registerR
 
-postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
+getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
-postRegisterR = registerHelper registerR
-
-getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html
 getForgotPasswordR = forgotPasswordHandler
 
 -- | Default implementation of 'forgotPasswordHandler'.
 --
 -- @since 1.2.6
-defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
+defaultForgotPasswordHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
 defaultForgotPasswordHandler = do
-    (widget, enctype) <- generateFormPost forgotPasswordForm
+    (widget, enctype) <- lift $ generateFormPost forgotPasswordForm
     toParent <- getRouteToParent
-    authLayout $ do
+    lift $ authLayout $ do
         setTitleI Msg.PasswordResetTitle
         [whamlet|
             <p>_{Msg.PasswordResetPrompt}
@@ -662,11 +553,11 @@ defaultForgotPasswordHandler = do
 
         let forgotPasswordRes = ForgotPasswordForm <$> emailRes
         let widget = do
-              [whamlet|
+            [whamlet|
-                  #{extra}
+                #{extra}
-                  ^{fvLabel emailView}
+                ^{fvLabel emailView}
-                  ^{fvInput emailView}
+                ^{fvInput emailView}
-              |]
+            |]
         return (forgotPasswordRes, widget)
 
     emailSettings =
@@ -678,45 +569,35 @@ defaultForgotPasswordHandler = do
             fsAttrs = [("autofocus", "")]
         }
 
-postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
+postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
-postForgotPasswordR = passwordResetHelper forgotPasswordR
+postForgotPasswordR = registerHelper True forgotPasswordR
 
 getVerifyR :: YesodAuthEmail site
            => AuthEmailId site
            -> Text
-           -> Bool
+           -> HandlerT Auth (HandlerT site IO) TypedContent
-           -> AuthHandler site TypedContent
+getVerifyR lid key = do
-getVerifyR lid key hasSetPass = do
+    realKey <- lift $ getVerifyKey lid
-    realKey <- getVerifyKey lid
+    memail <- lift $ getEmail lid
-    memail <- getEmail lid
+    mr <- lift getMessageRender
-    mr <- getMessageRender
     case (realKey == Just key, memail) of
         (True, Just email) -> do
-            muid <- verifyAccount lid
+            muid <- lift $ verifyAccount lid
             case muid of
                 Nothing -> invalidKey mr
                 Just uid -> do
-                    setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
+                    lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
-                    setLoginLinkKey uid
+                    lift $ setLoginLinkKey uid
-                    let msgAv = if hasSetPass
+                    let msgAv = Msg.AddressVerified
-                                  then Msg.EmailVerified
-                                  else Msg.EmailVerifiedChangePass
                     selectRep $ do
                       provideRep $ do
-                        addMessageI "success" msgAv
+                        lift $ addMessageI "success" msgAv
-                        redirectRoute <- if hasSetPass
+                        fmap asHtml $ redirect setpassR
-                            then do
-                              y <- getYesod
-                              return $ afterVerificationWithPass y
-                            else do
-                              tp <- getRouteToParent
-                              return $ tp setpassR
-                        fmap asHtml $ redirect redirectRoute
                       provideJsonMessage $ mr msgAv
         _ -> invalidKey mr
   where
     msgIk = Msg.InvalidKey
-    invalidKey mr = messageJson401 (mr msgIk) $ authLayout $ do
+    invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do
         setTitleI msgIk
         [whamlet|
 $newline never
@@ -731,35 +612,35 @@ parseCreds = withObject "creds" (\obj -> do
                                    return (email', pass))
 
 
-postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent
+postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postLoginR = do
-    result <- runInputPostResult $ (,)
+    result <- lift $ runInputPostResult $ (,)
         <$> ireq textField "email"
         <*> ireq textField "password"
 
     midentifier <- case result of
                      FormSuccess (iden, pass) -> return $ Just (iden, pass)
                      _ -> do
-                       (creds :: Result Value) <- parseCheckJsonBody
+                       (creds :: Result Value) <- lift parseCheckJsonBody
                        case creds of
-                         Error _     -> return Nothing
+                         Error _ -> return Nothing
                          Success val -> return $ parseMaybe parseCreds val
 
     case midentifier of
       Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided
       Just (identifier, pass) -> do
-          mecreds <- getEmailCreds identifier
+          mecreds <- lift $ getEmailCreds identifier
           maid <-
               case ( mecreds >>= emailCredsAuthId
                    , emailCredsEmail <$> mecreds
                    , emailCredsStatus <$> mecreds
                    ) of
                 (Just aid, Just email', Just True) -> do
-                      mrealpass <- getPassword aid
+                      mrealpass <- lift $ getPassword aid
                       case mrealpass of
                         Nothing -> return Nothing
                         Just realpass -> do
-                            passValid <- verifyPassword pass realpass
+                            passValid <- lift $ verifyPassword pass realpass 
                             return $ if passValid
                                     then Just email'
                                     else Nothing
@@ -767,7 +648,7 @@ postLoginR = do
           let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
           case maid of
             Just email' ->
-                setCredsRedirect $ Creds
+                lift $ setCredsRedirect $ Creds
                          (if isEmail then "email" else "username")
                          email'
                          [("verifiedEmail", email')]
@@ -777,26 +658,26 @@ postLoginR = do
                                    then Msg.InvalidEmailPass
                                    else Msg.InvalidUsernamePass
 
-getPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
+getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 getPasswordR = do
-    maid <- maybeAuthId
+    maid <- lift maybeAuthId
     case maid of
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-        Just aid -> do
+        Just _ -> do
-            needOld <- needOldPassword aid
+            needOld <- maybe (return True) (lift . needOldPassword) maid
             setPasswordHandler needOld
 
 -- | Default implementation of 'setPasswordHandler'.
 --
 -- @since 1.2.6
-defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
+defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> HandlerT Auth (HandlerT master IO) TypedContent
 defaultSetPasswordHandler needOld = do
-    messageRender <- getMessageRender
+    messageRender <- lift getMessageRender
     toParent <- getRouteToParent
     selectRep $ do
         provideJsonMessage $ messageRender Msg.SetPass
-        provideRep $ authLayout $ do
+        provideRep $ lift $ authLayout $ do
-            (widget, enctype) <- generateFormPost setPasswordForm
+            (widget, enctype) <- liftWidgetT $ generateFormPost setPasswordForm
             setTitleI Msg.SetPassTitle
             [whamlet|
                 <h3>_{Msg.SetPass}
@@ -811,29 +692,29 @@ defaultSetPasswordHandler needOld = do
 
         let passwordFormRes = PasswordForm <$> currentPasswordRes <*> newPasswordRes <*> confirmPasswordRes
         let widget = do
-              [whamlet|
+            [whamlet|
-                  #{extra}
+                #{extra}
-                  <table>
+                <table>
-                      $if needOld
+                    $if needOld
-                          <tr>
+                        <tr>
-                              <th>
+                            <th>
-                                  ^{fvLabel currentPasswordView}
+                                ^{fvLabel currentPasswordView}
-                              <td>
+                            <td>
-                                  ^{fvInput currentPasswordView}
+                                ^{fvInput currentPasswordView}
-                      <tr>
+                    <tr>
-                          <th>
+                        <th>
-                              ^{fvLabel newPasswordView}
+                            ^{fvLabel newPasswordView}
-                          <td>
+                        <td>
-                              ^{fvInput newPasswordView}
+                            ^{fvInput newPasswordView}
-                      <tr>
+                    <tr>
-                          <th>
+                        <th>
-                              ^{fvLabel confirmPasswordView}
+                            ^{fvLabel confirmPasswordView}
-                          <td>
+                        <td>
-                              ^{fvInput confirmPasswordView}
+                            ^{fvInput confirmPasswordView}
-                      <tr>
+                    <tr>
-                          <td colspan="2">
+                        <td colspan="2">
-                              <input type=submit value=_{Msg.SetPassTitle}>
+                            <input type=submit value=_{Msg.SetPassTitle}>
-              |]
+            |]
 
         return (passwordFormRes, widget)
     currentPasswordSettings =
@@ -868,75 +749,75 @@ parsePassword = withObject "password" (\obj -> do
                                          curr <- obj .:? "current"
                                          return (email', pass, curr))
 
-postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
+postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postPasswordR = do
-    maid <- maybeAuthId
+    maid <- lift maybeAuthId
-    (creds :: Result Value) <- parseCheckJsonBody
+    (creds :: Result Value) <- lift parseCheckJsonBody
     let jcreds = case creds of
-                   Error _     -> Nothing
+                   Error _ -> Nothing
                    Success val -> parseMaybe parsePassword val
     let doJsonParsing = isJust jcreds
     case maid of
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
         Just aid -> do
             tm <- getRouteToParent
-            needOld <- needOldPassword aid
+            needOld <- lift $ needOldPassword aid
             if not needOld then confirmPassword aid tm jcreds else do
-                res <- runInputPostResult $ ireq textField "current"
+                res <- lift $ runInputPostResult $ ireq textField "current"
                 let fcurrent = case res of
                                  FormSuccess currentPass -> Just currentPass
-                                 _                       -> Nothing
+                                 _ -> Nothing
                 let current = if doJsonParsing
                               then getThird jcreds
                               else fcurrent
-                mrealpass <- getPassword aid
+                mrealpass <- lift $ getPassword aid
                 case (mrealpass, current) of
                     (Nothing, _) ->
-                        loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
+                        lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
                     (_, Nothing) ->
                         loginErrorMessageI LoginR Msg.BadSetPass
                     (Just realpass, Just current') -> do
-                        passValid <- verifyPassword current' realpass
+                        passValid <- lift $ verifyPassword current' realpass
                         if passValid
                           then confirmPassword aid tm jcreds
-                          else loginErrorMessage (tm setpassR) "Invalid current password, please try again"
+                          else lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
 
   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 $ (,)
+        res <- lift $ runInputPostResult $ (,)
             <$> ireq textField "new"
             <*> ireq textField "confirm"
         let creds = if (isJust jcreds)
                     then getNewConfirm jcreds
                     else case res of
                            FormSuccess res' -> Just res'
-                           _                -> Nothing
+                           _ -> Nothing
         case creds of
           Nothing -> loginErrorMessageI setpassR Msg.PassMismatch
           Just (new, confirm) ->
               if new /= confirm
               then loginErrorMessageI setpassR Msg.PassMismatch
               else do
-                isSecure <- checkPasswordSecurity aid new
+                isSecure <- lift $ checkPasswordSecurity aid new
                 case isSecure of
-                  Left e -> loginErrorMessage (tm setpassR) e
+                  Left e -> lift $ loginErrorMessage (tm setpassR) e
                   Right () -> do
-                     salted <- hashAndSaltPassword new
+                     salted <- lift $ hashAndSaltPassword new
-                     y <- do
+                     y <- lift $ do
                                 setPassword aid salted
                                 deleteSession loginLinkKey
                                 addMessageI "success" msgOk
                                 getYesod
 
-                     mr <- getMessageRender
+                     mr <- lift getMessageRender
                      selectRep $ do
-                         provideRep $
+                         provideRep $ 
-                            fmap asHtml $ redirect $ afterPasswordRoute y
+                            fmap asHtml $ lift $ redirect $ afterPasswordRoute y
                          provideJsonMessage (mr msgOk)
 
 saltLength :: Int

yesod-auth/Yesod/Auth/GoogleEmail.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
+-- | Use an email address as an identifier via Google's OpenID login system.
+--
+-- This backend will not use the OpenID identifier at all. It only uses OpenID
+-- as a login system. By using this plugin, you are trusting Google to validate
+-- an email address, and requiring users to have a Google account. On the plus
+-- side, you get to use email addresses as the identifier, many users have
+-- existing Google accounts, the login system has been long tested (as opposed
+-- to BrowserID), and it requires no credential managing or setup (as opposed
+-- to Email).
+module Yesod.Auth.GoogleEmail
+    {-# DEPRECATED "Google no longer provides OpenID support, please use Yesod.Auth.GoogleEmail2" #-}
+    ( authGoogleEmail
+    , forwardUrl
+    ) where
+
+import Yesod.Auth
+import qualified Web.Authenticate.OpenId as OpenId
+
+import Yesod.Core
+import Data.Text (Text)
+import qualified Yesod.Auth.Message as Msg
+import qualified Data.Text as T
+import Control.Exception.Lifted (try, SomeException)
+
+pid :: Text
+pid = "googleemail"
+
+forwardUrl :: AuthRoute
+forwardUrl = PluginR pid ["forward"]
+
+googleIdent :: Text
+googleIdent = "https://www.google.com/accounts/o8/id"
+
+authGoogleEmail :: YesodAuth m => AuthPlugin m
+authGoogleEmail =
+    AuthPlugin pid dispatch login
+  where
+    complete = PluginR pid ["complete"]
+    login tm =
+        [whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
+    dispatch "GET" ["forward"] = do
+        render <- getUrlRender
+        let complete' = render complete
+        master <- lift getYesod
+        eres <- lift $ try $ OpenId.getForwardUrl googleIdent complete' Nothing
+            [ ("openid.ax.type.email", "http://schema.openid.net/contact/email")
+            , ("openid.ns.ax", "http://openid.net/srv/ax/1.0")
+            , ("openid.ns.ax.required", "email")
+            , ("openid.ax.mode", "fetch_request")
+            , ("openid.ax.required", "email")
+            , ("openid.ui.icon", "true")
+            ] (authHttpManager master)
+        either
+          (\err -> do
+            tm <- getRouteToParent
+            lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException))
+          redirect
+          eres
+    dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
+    dispatch "GET" ["complete"] = do
+        rr <- getRequest
+        completeHelper $ reqGetParams rr
+    dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues
+    dispatch "POST" ["complete"] = do
+        (posts, _) <- runRequestBody
+        completeHelper posts
+    dispatch _ _ = notFound
+
+completeHelper :: [(Text, Text)] -> AuthHandler master TypedContent
+completeHelper gets' = do
+      master <- lift getYesod
+      eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
+      tm <- getRouteToParent
+      either (onFailure tm) (onSuccess tm) eres
+    where
+      onFailure tm err =
+        lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)
+      onSuccess tm oir = do
+              let OpenId.Identifier ident = OpenId.oirOpLocal oir
+              memail <- lookupGetParam "openid.ext1.value.email"
+              case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
+                  (Just email, True) -> lift $ setCredsRedirect $ Creds pid email []
+                  (_, False)   -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"
+                  (Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -2,8 +2,6 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE TypeFamilies      #-}
 -- | Use an email address as an identifier via Google's login system.
 --
 -- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends
@@ -26,7 +24,6 @@
 --
 -- @since 1.3.1
 module Yesod.Auth.GoogleEmail2
-    {-# DEPRECATED "Google+ is being shut down, please migrate to Google Sign-in https://pbrisbin.com/posts/googleemail2_deprecation/" #-}
     ( -- * Authentication handlers
       authGoogleEmail
     , authGoogleEmailSaveToken
@@ -53,61 +50,55 @@ module Yesod.Auth.GoogleEmail2
     , pid
     ) where
 
-import           Yesod.Auth                  (Auth, AuthHandler,
+import           Yesod.Auth               (Auth, AuthPlugin (AuthPlugin),
-                                              AuthPlugin (AuthPlugin),
+                                           AuthRoute, Creds (Creds),
-                                              AuthRoute, Creds (Creds),
+                                           Route (PluginR), YesodAuth,
-                                              Route (PluginR), YesodAuth,
+                                           runHttpRequest, setCredsRedirect,
-                                              logoutDest, runHttpRequest,
+                                           logoutDest)
-                                              setCredsRedirect)
+import qualified Yesod.Auth.Message       as Msg
-import qualified Yesod.Auth.Message          as Msg
+import           Yesod.Core               (HandlerSite, HandlerT, MonadHandler,
-import           Yesod.Core                  (HandlerSite, MonadHandler,
+                                           TypedContent, getRouteToParent,
-                                              TypedContent, addMessage,
+                                           getUrlRender, invalidArgs,
-                                              getRouteToParent, getUrlRender,
+                                           lift, liftIO, lookupGetParam,
-                                              getYesod, invalidArgs, liftIO,
+                                           lookupSession, notFound, redirect,
-                                              liftSubHandler, lookupGetParam,
+                                           setSession, whamlet, (.:),
-                                              lookupSession, notFound, redirect,
+                                           addMessage, getYesod,
-                                              setSession, toHtml, whamlet, (.:))
+                                           toHtml)
 
 
-import           Blaze.ByteString.Builder    (fromByteString, toByteString)
+import           Blaze.ByteString.Builder (fromByteString, toByteString)
-import           Control.Applicative         ((<$>), (<*>))
+import           Control.Applicative      ((<$>), (<*>))
-import           Control.Arrow               (second)
+import           Control.Arrow            (second)
-import           Control.Monad               (unless, when)
+import           Control.Monad            (unless, when)
-import           Control.Monad.IO.Class      (MonadIO)
+import           Control.Monad.IO.Class   (MonadIO)
-import qualified Crypto.Nonce                as Nonce
+import qualified Crypto.Nonce             as Nonce
-import           Data.Aeson                  ((.:?))
+import           Data.Aeson               ((.:?))
-import qualified Data.Aeson                  as A
+import qualified Data.Aeson               as A
 #if MIN_VERSION_aeson(1,0,0)
-import qualified Data.Aeson.Text             as A
+import qualified Data.Aeson.Text          as A
 #else
-import qualified Data.Aeson.Encode           as A
+import qualified Data.Aeson.Encode        as A
 #endif
-import           Data.Aeson.Parser           (json')
+import           Data.Aeson.Parser        (json')
-import           Data.Aeson.Types            (FromJSON (parseJSON), parseEither,
+import           Data.Aeson.Types         (FromJSON (parseJSON), parseEither,
-                                              parseMaybe, withObject, withText)
+                                           parseMaybe, withObject, withText)
-import           Data.Conduit
+import           Data.Conduit             (($$+-), ($$))
-import           Data.Conduit.Attoparsec     (sinkParser)
+import           Data.Conduit.Attoparsec  (sinkParser)
-import           Data.Maybe                  (fromMaybe)
+import qualified Data.HashMap.Strict      as M
-import           Data.Monoid                 (mappend)
+import           Data.Maybe               (fromMaybe)
-import           Data.Text                   (Text)
+import           Data.Monoid              (mappend)
-import qualified Data.Text                   as T
+import           Data.Text                (Text)
-import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)
+import qualified Data.Text                as T
-import qualified Data.Text.Lazy              as TL
+import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)
-import qualified Data.Text.Lazy.Builder      as TL
+import qualified Data.Text.Lazy           as TL
-import           Network.HTTP.Client         (Manager, requestHeaders,
+import qualified Data.Text.Lazy.Builder   as TL
-                                              responseBody, urlEncodedBody)
+import           Network.HTTP.Client      (Manager, requestHeaders,
-import qualified Network.HTTP.Client         as HTTP
+                                           responseBody, urlEncodedBody)
+import qualified Network.HTTP.Client      as HTTP
 import           Network.HTTP.Client.Conduit (Request, bodyReaderSource)
-import           Network.HTTP.Conduit        (http)
+import           Network.HTTP.Conduit (http)
-import           Network.HTTP.Types          (renderQueryText)
+import           Network.HTTP.Types       (renderQueryText)
-import           System.IO.Unsafe            (unsafePerformIO)
+import           System.IO.Unsafe         (unsafePerformIO)
-
-#if MIN_VERSION_aeson(2, 0, 0)
-import qualified Data.Aeson.Key
-import qualified Data.Aeson.KeyMap
-#else
-import qualified Data.HashMap.Strict         as M
-#endif
 
 
 -- | Plugin identifier. This is used to identify the plugin used for
@@ -196,10 +187,10 @@ authPlugin storeToken clientID clientSecret =
     dispatch :: YesodAuth site
              => Text
              -> [Text]
-             -> AuthHandler site TypedContent
+             -> HandlerT Auth (HandlerT site IO) TypedContent
     dispatch "GET" ["forward"] = do
         tm <- getRouteToParent
-        getDest tm >>= redirect
+        lift (getDest tm) >>= redirect
 
     dispatch "GET" ["complete"] = do
         mstate <- lookupGetParam "state"
@@ -216,27 +207,30 @@ authPlugin storeToken clientID clientSecret =
                     case merr of
                         Nothing -> invalidArgs ["Missing code paramter"]
                         Just err -> do
-                            master <- getYesod
+                            master <- lift getYesod
                             let msg =
                                     case err of
                                         "access_denied" -> "Access denied"
                                         _ -> "Unknown error occurred: " `T.append` err
                             addMessage "error" $ toHtml msg
-                            redirect $ logoutDest master
+                            lift $ redirect $ logoutDest master
                 Just c -> return c
 
         render <- getUrlRender
-        tm <- getRouteToParent
 
         req' <- liftIO $
+#if MIN_VERSION_http_client(0,4,30)
             HTTP.parseUrlThrow
+#else
+            HTTP.parseUrl
+#endif
             "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
         let req =
                 urlEncodedBody
                     [ ("code", encodeUtf8 code)
                     , ("client_id", encodeUtf8 clientID)
                     , ("client_secret", encodeUtf8 clientSecret)
-                    , ("redirect_uri", encodeUtf8 $ render $ tm complete)
+                    , ("redirect_uri", encodeUtf8 $ render complete)
                     , ("grant_type", "authorization_code")
                     ]
                     req'
@@ -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,43 +247,48 @@ authPlugin storeToken clientID clientSecret =
         -- User's access token is saved for further access to API
         when storeToken $ setSession accessTokenKey accessToken'
 
-        personValReq <- personValueRequest token
+        personValue <- makeHttpRequest =<< personValueRequest token
-        personValue <- makeHttpRequest personValReq
-
         person <- case parseEither parseJSON personValue of
-                Left e  -> error e
+                Left e -> error e
                 Right x -> return x
 
         email <-
             case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of
                 [e] -> return e
-                []  -> error "No account email"
+                [] -> error "No account email"
-                x   -> error $ "Too many account emails: " ++ show x
+                x -> error $ "Too many account emails: " ++ show x
-        setCredsRedirect $ Creds pid email $ allPersonInfo personValue
+        lift $ setCredsRedirect $ Creds pid email $ allPersonInfo personValue
 
     dispatch _ _ = notFound
 
-makeHttpRequest :: Request -> AuthHandler site A.Value
+makeHttpRequest
-makeHttpRequest req =
+  :: (YesodAuth site)
-    liftSubHandler $ runHttpRequest req $ \res ->
+  => Request
-    runConduit $ bodyReaderSource (responseBody res) .| sinkParser json'
+  -> HandlerT Auth (HandlerT site IO) A.Value
+makeHttpRequest req = lift $
+    runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json'
 
 -- | Allows to fetch information about a user from Google's API.
 --   In case of parsing error returns 'Nothing'.
 --   Will throw 'HttpException' in case of network problems or error response code.
 --
 -- @since 1.4.3
-getPerson :: MonadHandler m => Manager -> Token -> m (Maybe Person)
+getPerson :: Manager -> Token -> HandlerT site IO (Maybe Person)
-getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do
+getPerson manager token = parseMaybe parseJSON <$> (do
     req <- personValueRequest token
     res <- http req manager
-    runConduit $ responseBody res .| sinkParser json'
+    responseBody res $$+- sinkParser json'
   )
 
 personValueRequest :: MonadIO m => Token -> m Request
 personValueRequest token = do
-    req2' <- liftIO
+    req2' <- liftIO $
-           $ HTTP.parseUrlThrow "https://www.googleapis.com/plus/v1/people/me"
+#if MIN_VERSION_http_client(0,4,30)
+            HTTP.parseUrlThrow
+#else
+            HTTP.parseUrl
+#endif
+        "https://www.googleapis.com/plus/v1/people/me"
     return req2'
             { requestHeaders =
                 [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)
@@ -458,16 +457,16 @@ data RelationshipStatus = Single              -- ^ Person is single
 
 instance FromJSON RelationshipStatus where
     parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of
-                  "single"                  -> Single
+                  "single"                    -> Single
-                  "in_a_relationship"       -> InRelationship
+                  "in_a_relationship"         -> InRelationship
-                  "engaged"                 -> Engaged
+                  "engaged"                   -> Engaged
-                  "married"                 -> Married
+                  "married"                   -> Married
-                  "its_complicated"         -> Complicated
+                  "its_complicated"           -> Complicated
-                  "open_relationship"       -> OpenRelationship
+                  "open_relationship"         -> OpenRelationship
-                  "widowed"                 -> Widowed
+                  "widowed"                   -> Widowed
-                  "in_domestic_partnership" -> DomesticPartnership
+                  "in_domestic_partnership"   -> DomesticPartnership
-                  "in_civil_union"          -> CivilUnion
+                  "in_civil_union"            -> CivilUnion
-                  _                         -> RelationshipStatus t
+                  _                           -> RelationshipStatus t
 
 --------------------------------------------------------------------------------
 -- | The URI of the person's profile photo.
@@ -593,19 +592,9 @@ instance FromJSON EmailType where
         _         -> EmailType t
 
 allPersonInfo :: A.Value -> [(Text, Text)]
-allPersonInfo (A.Object o) = map enc $ mapToList o
+allPersonInfo (A.Object o) = map enc $ M.toList o
-  where
+    where enc (key, A.String s) = (key, s)
-    enc (key, A.String s) = (keyToText key, s)
+          enc (key, v) = (key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
-    enc (key, v) = (keyToText key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
-
-#if MIN_VERSION_aeson(2, 0, 0)
-    keyToText = Data.Aeson.Key.toText
-    mapToList = Data.Aeson.KeyMap.toList
-#else
-    keyToText = id
-    mapToList = M.toList
-#endif
-
 allPersonInfo _ = []
 
 

yesod-auth/Yesod/Auth/Hardcoded.hs

@@ -52,7 +52,7 @@ be unique).
 'AuthId' must have an instance of 'PathPiece' class, this is needed to store
 user identifier in session (this happens in 'setCreds' and 'setCredsRedirect'
 actions) and to read that identifier from session (this happens in
-`defaultMaybeAuthId` action).  So we have to define it:
+`dafaultMaybeAuthId` action).  So we have to define it:
 
 @
 import Text.Read (readMaybe)
@@ -85,7 +85,7 @@ Here @lookupUser@ is just a helper function to lookup hardcoded users by name:
 
 @
 lookupUser :: Text -> Maybe SiteManager
-lookupUser username = find (\\m -> manUserName m == username) siteManagers
+lookupUser username = find (\m -> manUserName m == username) siteManagers
 @
 
 
@@ -113,7 +113,7 @@ instance YesodAuthHardcoded App where
 
 validPassword :: Text -> Text -> Bool
 validPassword u p =
-  case find (\\m -> manUserName m == u && manPassWord m == p) siteManagers of
+  case find (\m -> manUserName m == u && manPassWord m == p) siteManagers of
     Just _ -> True
     _      -> False
 @
@@ -131,7 +131,7 @@ module Yesod.Auth.Hardcoded
   , loginR )
   where
 
-import           Yesod.Auth          (AuthHandler, AuthPlugin (..), AuthRoute,
+import           Yesod.Auth          (Auth, AuthPlugin (..), AuthRoute,
                                       Creds (..), Route (..), YesodAuth,
                                       loginErrorMessageI, setCredsRedirect)
 import qualified Yesod.Auth.Message  as Msg
@@ -148,19 +148,18 @@ loginR = PluginR "hardcoded" ["login"]
 class (YesodAuth site) => YesodAuthHardcoded site where
 
   -- | Check whether given user name exists among hardcoded names.
-  doesUserNameExist :: Text -> AuthHandler site Bool
+  doesUserNameExist :: Text -> HandlerT site IO Bool
 
   -- | Validate given user name with given password.
-  validatePassword :: Text -> Text -> AuthHandler site Bool
+  validatePassword :: Text -> Text -> HandlerT site IO Bool
 
 
 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|
@@ -183,16 +182,16 @@ authHardcoded =
         |]
 
 
-postLoginR :: YesodAuthHardcoded site
+postLoginR :: (YesodAuthHardcoded master)
-           => AuthHandler site TypedContent
+           => HandlerT Auth (HandlerT master IO) TypedContent
 postLoginR =
-  do (username, password) <- runInputPost
+  do (username, password) <- lift (runInputPost
        ((,) Control.Applicative.<$> ireq textField "username"
-            Control.Applicative.<*> ireq textField "password")
+            Control.Applicative.<*> ireq textField "password"))
-     isValid <- validatePassword username password
+     isValid <- lift (validatePassword username password)
      if isValid
-        then setCredsRedirect (Creds "hardcoded" username [])
+        then lift (setCredsRedirect (Creds "hardcoded" username []))
-        else do isExists <- doesUserNameExist username
+        else do isExists <- lift (doesUserNameExist username)
                 loginErrorMessageI LoginR
                                    (if isExists
                                        then Msg.InvalidUsernamePass

yesod-auth/Yesod/Auth/Message.hs

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

yesod-auth/Yesod/Auth/OpenId.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE GADTs #-}
 module Yesod.Auth.OpenId
     ( authOpenId
     , forwardUrl
@@ -20,7 +19,7 @@ import Yesod.Form
 import Yesod.Core
 import Data.Text (Text, isPrefixOf)
 import qualified Yesod.Auth.Message as Msg
-import UnliftIO.Exception (tryAny)
+import Control.Exception.Lifted (SomeException, try)
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 
@@ -37,10 +36,7 @@ authOpenId idType extensionFields =
     AuthPlugin "openid" dispatch login
   where
     complete = PluginR "openid" ["complete"]
-
-    name :: Text
     name = "openid_identifier"
-
     login tm = do
         ident <- newIdent
         -- FIXME this is a hack to get GHC 7.6's type checker to allow the
@@ -61,19 +57,19 @@ $newline never
     <input id="#{ident}" type="text" name="#{name}" value="http://">
     <input type="submit" value="_{Msg.LoginOpenID}">
 |]
-
-    dispatch :: Text -> [Text] -> AuthHandler master TypedContent
     dispatch "GET" ["forward"] = do
-        roid <- runInputGet $ iopt textField name
+        roid <- lift $ runInputGet $ iopt textField name
         case roid of
             Just oid -> do
-                tm <- getRouteToParent
                 render <- getUrlRender
-                let complete' = render $ tm complete
+                let complete' = render complete
-                manager <- authHttpManager
+                master <- lift getYesod
-                eres <- tryAny $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager
+                eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master)
                 case eres of
-                    Left err -> loginErrorMessage (tm LoginR) $ T.pack $ show err
+                    Left err -> do
+                        tm <- getRouteToParent
+                        lift $ loginErrorMessage (tm LoginR) $ T.pack $
+                                show (err :: SomeException)
                     Right x -> redirect x
             Nothing -> loginErrorMessageI LoginR Msg.NoOpenID
     dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
@@ -88,13 +84,14 @@ $newline never
 
 completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
 completeHelper idType gets' = do
-    manager <- authHttpManager
+    master <- lift getYesod
-    eres <- tryAny $ OpenId.authenticateClaimed gets' manager
+    eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
     either onFailure onSuccess eres
   where
     onFailure err = do
         tm <- getRouteToParent
-        loginErrorMessage (tm LoginR) $ T.pack $ show err
+        lift $ loginErrorMessage (tm LoginR) $ T.pack $
+                show (err :: SomeException)
     onSuccess oir = do
             let claimed =
                     case OpenId.oirClaimed oir of
@@ -108,7 +105,7 @@ completeHelper idType gets' = do
                         case idType of
                             OPLocal -> OpenId.oirOpLocal oir
                             Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
-            setCredsRedirect $ Creds "openid" i gets''
+            lift $ setCredsRedirect $ Creds "openid" i gets''
 
 -- | The main identifier provided by the OpenID authentication plugin is the
 -- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier

yesod-auth/Yesod/Auth/Routes.hs

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

yesod-auth/Yesod/Auth/Rpxnow.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
 module Yesod.Auth.Rpxnow
     ( authRpxnow
     ) where
@@ -18,10 +17,10 @@ import Data.Text.Encoding.Error (lenientDecode)
 import Control.Arrow ((***))
 import Network.HTTP.Types (renderQuery)
 
-authRpxnow :: YesodAuth master
+authRpxnow :: YesodAuth m
            => String -- ^ app name
            -> String -- ^ key
-           -> AuthPlugin master
+           -> AuthPlugin m
 authRpxnow app apiKey =
     AuthPlugin "rpxnow" dispatch login
   where
@@ -33,16 +32,14 @@ authRpxnow app apiKey =
 $newline never
 <iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
 |]
-
-    dispatch :: a -> [b] -> AuthHandler master TypedContent
     dispatch _ [] = do
         token1 <- lookupGetParams "token"
         token2 <- lookupPostParams "token"
         token <- case token1 ++ token2 of
                         [] -> invalidArgs ["token: Value not supplied"]
                         x:_ -> return $ unpack x
-        manager <- authHttpManager
+        master <- lift getYesod
-        Rpxnow.Identifier ident extra <- Rpxnow.authenticate apiKey token manager
+        Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master)
         let creds =
                 Creds "rpxnow" ident
                 $ maybe id (\x -> (:) ("verifiedEmail", x))
@@ -50,7 +47,7 @@ $newline never
                 $ maybe id (\x -> (:) ("displayName", x))
                     (fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
                   []
-        setCredsRedirect creds
+        lift $ setCredsRedirect creds
     dispatch _ _ = notFound
 
 -- | Get some form of a display name.

yesod-auth/yesod-auth.cabal

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

yesod-bin/AddHandler.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE PatternGuards #-}
 module AddHandler (addHandler) where
 
@@ -9,18 +8,7 @@ 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)
-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 +55,18 @@ addHandlerInteractive :: IO ()
 addHandlerInteractive = do
     cabal <- getCabal
     let routeInput = do
-          putStr "Name of route (without trailing R): "
+        putStr "Name of route (without trailing R): "
-          hFlush stdout
+        hFlush stdout
-          name <- getLine
+        name <- getLine
-          checked <- checkRoute name cabal
+        checked <- checkRoute name cabal
-          case checked of
+        case checked of
-              Left err@EmptyRoute -> (error . show) err
+            Left err@EmptyRoute -> (error . show) err
-              Left err@RouteCaseError -> print err >> routeInput
+            Left err@RouteCaseError -> print err >> routeInput
-              Left err@(RouteExists _) -> do
+            Left err@(RouteExists _) -> do
-                print err
+              print err
-                putStrLn "Try another name or leave blank to exit"
+              putStrLn "Try another name or leave blank to exit"
-                routeInput
+              routeInput
-              Right p -> return p
+            Right p -> return p
 
     routePair <- routeInput
     putStr "Enter route pattern (ex: /entry/#EntryId): "
@@ -89,22 +77,13 @@ addHandlerInteractive = do
     methods <- getLine
     addHandlerFiles cabal routePair pattern methods
 
-getRoutesFilePath :: IO FilePath
-getRoutesFilePath = do
-    let oldPath = "config/routes"
-    oldExists <- doesFileExist oldPath
-    pure $ if oldExists
-        then oldPath
-        else "config/routes.yesodroutes"
-
 addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO ()
 addHandlerFiles cabal (name, handlerFile) pattern methods = do
     src <- getSrcDir cabal
     let applicationFile = concat [src, "/Application.hs"]
     modify applicationFile $ fixApp name
     modify cabal $ fixCabal name
-    routesPath <- getRoutesFilePath
+    modify "config/routes" $ fixRoutes name pattern methods
-    modify routesPath $ fixRoutes name pattern methods
     writeFile handlerFile $ mkHandler name pattern methods
     specExists <- doesFileExist specFile
     unless specExists $
@@ -245,15 +224,7 @@ uncapitalize "" = ""
 
 getSrcDir :: FilePath -> IO FilePath
 getSrcDir cabal = do
-#if MIN_VERSION_Cabal(2, 0, 0)
-    pd <- flattenPackageDescription <$> readGenericPackageDescription normal cabal
-#else
     pd <- flattenPackageDescription <$> readPackageDescription normal cabal
-#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/Build.hs

@@ -0,0 +1,270 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Build
+    ( getDeps
+    , touchDeps
+    , touch
+    , recompDeps
+    , isNewerThan
+    , safeReadFile
+    ) where
+
+import           Control.Applicative as App ((<|>), many, (<$>))
+import qualified Data.Attoparsec.Text as A
+import           Data.Char (isSpace, isUpper)
+import qualified Data.Text as T
+import           Data.Text.Encoding (decodeUtf8With)
+import           Data.Text.Encoding.Error (lenientDecode)
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as S
+
+import           Control.Exception (SomeException, try, IOException)
+import           Control.Exception.Lifted (handle)
+import           Control.Monad (when, filterM, forM, forM_, (>=>))
+import           Control.Monad.Trans.State (StateT, get, put, execStateT)
+import           Control.Monad.Trans.Writer (WriterT, tell, execWriterT)
+import           Control.Monad.IO.Class (MonadIO, liftIO)
+import           Control.Monad.Trans.Class (lift)
+
+import           Data.Monoid (Monoid (..))
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import qualified System.Posix.Types
+import           System.Directory
+import           System.FilePath (takeExtension, replaceExtension, (</>), takeDirectory,
+                                    splitPath, joinPath)
+import           System.PosixCompat.Files (getFileStatus, setFileTimes,
+                                             accessTime, modificationTime)
+
+import           Text.Shakespeare (Deref)
+import           Text.Julius      (juliusUsedIdentifiers)
+import           Text.Cassius     (cassiusUsedIdentifiers)
+import           Text.Lucius      (luciusUsedIdentifiers)
+
+safeReadFile :: MonadIO m => FilePath -> m (Either IOException ByteString)
+safeReadFile = liftIO . try . S.readFile
+
+touch :: IO ()
+touch = do
+    m <- handle (\(_ :: SomeException) -> return Map.empty) $ readFile touchCache >>= readIO
+    x <- fmap snd (getDeps [])
+    m' <- execStateT (execWriterT $ touchDeps id updateFileTime x) m
+    createDirectoryIfMissing True $ takeDirectory touchCache
+    writeFile touchCache $ show m'
+  where
+    touchCache = "dist/touchCache.txt"
+
+-- | Returns True if any files were touched, otherwise False
+recompDeps :: [FilePath] -> StateT (Map.Map FilePath (Set.Set Deref)) IO Bool
+recompDeps =
+    fmap toBool . execWriterT . (liftIO . getDeps >=> touchDeps hiFile removeHi . snd)
+  where
+    toBool NoFilesTouched = False
+    toBool SomeFilesTouched = True
+
+type Deps = Map.Map FilePath ([FilePath], ComparisonType)
+
+getDeps :: [FilePath] -> IO ([FilePath], Deps)
+getDeps hsSourceDirs = do
+    let defSrcDirs = case hsSourceDirs of
+                        [] -> ["."]
+                        ds -> ds
+    hss <- fmap concat $ mapM findHaskellFiles defSrcDirs
+    deps' <- mapM determineDeps hss
+    return $ (hss, fixDeps $ zip hss deps')
+
+data AnyFilesTouched = NoFilesTouched | SomeFilesTouched
+instance Data.Monoid.Monoid AnyFilesTouched where
+    mempty = NoFilesTouched
+    mappend NoFilesTouched NoFilesTouched = mempty
+    mappend _ _ = SomeFilesTouched
+
+touchDeps :: (FilePath -> FilePath) ->
+             (FilePath -> FilePath -> IO ()) ->
+             Deps -> WriterT AnyFilesTouched (StateT (Map.Map FilePath (Set.Set Deref)) IO) ()
+touchDeps f action deps = (mapM_ go . Map.toList) deps
+  where
+    go (x, (ys, ct)) = do
+        isChanged <- handle (\(_ :: SomeException) -> return True) $ lift $
+            case ct of
+                AlwaysOutdated -> return True
+                CompareUsedIdentifiers getDerefs -> do
+                    derefMap <- get
+                    ebs <- safeReadFile x
+                    let newDerefs =
+                            case ebs of
+                                Left _ -> Set.empty
+                                Right bs -> Set.fromList $ getDerefs $ T.unpack $ decodeUtf8With lenientDecode bs
+                    put $ Map.insert x newDerefs derefMap
+                    case Map.lookup x derefMap of
+                        Just oldDerefs | oldDerefs == newDerefs -> return False
+                        _ -> return True
+        when isChanged $ forM_ ys $ \y -> do
+            n <- liftIO $ x `isNewerThan` f y
+            when n $ do
+                liftIO $ putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x)
+                liftIO $ action x y
+                tell SomeFilesTouched
+
+-- | remove the .hi files for a .hs file, thereby forcing a recompile
+removeHi :: FilePath -> FilePath -> IO ()
+removeHi _ hs = mapM_ removeFile' hiFiles
+    where
+      removeFile' file = try' (removeFile file) >> return ()
+      hiFiles          = map (\e -> "dist/build" </> removeSrc (replaceExtension hs e))
+                             ["hi", "p_hi"]
+
+-- | change file mtime of .hs file to that of the dependency
+updateFileTime :: FilePath -> FilePath -> IO ()
+updateFileTime x hs = do
+  (_     , modx) <- getFileStatus' x
+  (access, _   ) <- getFileStatus' hs
+  _ <- try' (setFileTimes hs access modx)
+  return ()
+
+hiFile :: FilePath -> FilePath
+hiFile hs = "dist/build" </> removeSrc (replaceExtension hs "hi")
+
+removeSrc :: FilePath -> FilePath
+removeSrc f = case splitPath f of
+    ("src/" : xs) -> joinPath xs
+    _ -> f
+
+try' :: IO x -> IO (Either SomeException x)
+try' = try
+
+isNewerThan :: FilePath -> FilePath -> IO Bool
+isNewerThan f1 f2 = do
+  (_, mod1) <- getFileStatus' f1
+  (_, mod2) <- getFileStatus' f2
+  return (mod1 > mod2)
+
+getFileStatus' :: FilePath ->
+                  IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime)
+getFileStatus' fp = do
+    efs <- try' $ getFileStatus fp
+    case efs of
+        Left _ -> return (0, 0)
+        Right fs -> return (accessTime fs, modificationTime fs)
+
+fixDeps :: [(FilePath, [(ComparisonType, FilePath)])] -> Deps
+fixDeps =
+    Map.unionsWith combine . map go
+  where
+    go :: (FilePath, [(ComparisonType, FilePath)]) -> Deps
+    go (x, ys) = Map.fromList $ map (\(ct, y) -> (y, ([x], ct))) ys
+
+    combine (ys1, ct) (ys2, _) = (ys1 `mappend` ys2, ct)
+
+findHaskellFiles :: FilePath -> IO [FilePath]
+findHaskellFiles path = do
+    contents <- getDirectoryContents path
+    fmap concat $ mapM go contents
+  where
+    go ('.':_)          = return []
+    go filename = do
+        d <- doesDirectoryExist full
+        if not d
+          then if isHaskellFile
+                  then return [full]
+                  else return []
+          else if isHaskellDir
+                 then findHaskellFiles full
+                 else return []
+      where
+        -- this could fail on unicode
+        isHaskellDir  = isUpper (head filename)
+        isHaskellFile = takeExtension filename `elem` watch_files
+        full = path </> filename
+        watch_files = [".hs", ".lhs"]
+
+data TempType = StaticFiles FilePath
+              | Verbatim | Messages FilePath | Hamlet | Widget | Julius | Cassius | Lucius
+    deriving Show
+
+-- | How to tell if a file is outdated.
+data ComparisonType = AlwaysOutdated
+                    | CompareUsedIdentifiers (String -> [Deref])
+
+determineDeps :: FilePath -> IO [(ComparisonType, FilePath)]
+determineDeps x = do
+    y <- safeReadFile x
+    case y of
+        Left _ -> return []
+        Right bs -> do
+            let z = A.parseOnly (many $ (parser <|> (A.anyChar >> return Nothing)))
+                  $ decodeUtf8With lenientDecode bs
+            case z of
+                Left _ -> return []
+                Right r -> mapM go r >>= filterM (doesFileExist . snd) . concat
+  where
+    go (Just (StaticFiles fp, _)) = map ((,) AlwaysOutdated) App.<$> getFolderContents fp
+    go (Just (Hamlet, f)) = return [(AlwaysOutdated, f)]
+    go (Just (Widget, f)) = return
+        [ (AlwaysOutdated, "templates/" ++ f ++ ".hamlet")
+        , (CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, "templates/" ++ f ++ ".julius")
+        , (CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, "templates/" ++ f ++ ".lucius")
+        , (CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, "templates/" ++ f ++ ".cassius")
+        ]
+    go (Just (Julius, f)) = return [(CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, f)]
+    go (Just (Cassius, f)) = return [(CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, f)]
+    go (Just (Lucius, f)) = return [(CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, f)]
+    go (Just (Verbatim, f)) = return [(AlwaysOutdated, f)]
+    go (Just (Messages f, _)) = map ((,) AlwaysOutdated) <$> getFolderContents f
+    go Nothing = return []
+
+    parser = do
+        ty <- (do _ <- A.string "\nstaticFiles \""
+                  x' <- A.many1 $ A.satisfy (/= '"')
+                  return $ StaticFiles x')
+           <|> (A.string "$(parseRoutesFile " >> return Verbatim)
+           <|> (A.string "$(hamletFile " >> return Hamlet)
+           <|> (A.string "$(ihamletFile " >> return Hamlet)
+           <|> (A.string "$(whamletFile " >> return Hamlet)
+           <|> (A.string "$(html " >> return Hamlet)
+           <|> (A.string "$(widgetFile " >> return Widget)
+           <|> (A.string "$(Settings.hamletFile " >> return Hamlet)
+           <|> (A.string "$(Settings.widgetFile " >> return Widget)
+           <|> (A.string "$(juliusFile " >> return Julius)
+           <|> (A.string "$(cassiusFile " >> return Cassius)
+           <|> (A.string "$(luciusFile " >> return Lucius)
+           <|> (A.string "$(persistFile " >> return Verbatim)
+           <|> (
+                   A.string "$(persistFileWith " >>
+                   A.many1 (A.satisfy (/= '"')) >>
+                   return Verbatim)
+           <|> (do
+                    _ <- A.string "\nmkMessage \""
+                    A.skipWhile (/= '"')
+                    _ <- A.string "\" \""
+                    x' <- A.many1 $ A.satisfy (/= '"')
+                    _ <- A.string "\" \""
+                    _y <- A.many1 $ A.satisfy (/= '"')
+                    _ <- A.string "\""
+                    return $ Messages x')
+        case ty of
+            Messages{} -> return $ Just (ty, "")
+            StaticFiles{} -> return $ Just (ty, "")
+            _ -> do
+                A.skipWhile isSpace
+                _ <- A.char '"'
+                y <- A.many1 $ A.satisfy (/= '"')
+                _ <- A.char '"'
+                A.skipWhile isSpace
+                _ <- A.char ')'
+                return $ Just (ty, y)
+
+    getFolderContents :: FilePath -> IO [FilePath]
+    getFolderContents fp = do
+        cs <- getDirectoryContents fp
+        let notHidden ('.':_) = False
+            notHidden ('t':"mp") = False
+            notHidden ('f':"ay") = False
+            notHidden _ = True
+        fmap concat $ forM (filter notHidden cs) $ \c -> do
+            let f = fp ++ '/' : c
+            isFile <- doesFileExist f
+            if isFile then return [f] else getFolderContents f

yesod-bin/ChangeLog.md

@@ -1,54 +1,3 @@
-# ChangeLog for yesod-bin
-
-## 1.6.2.2
-
-* Support Cabal 3.8 [#1769](https://github.com/yesodweb/yesod/pull/1769)
-
-## 1.6.2.1
-
-* Support Cabal 3.6 [#1754](https://github.com/yesodweb/yesod/pull/1754)
-
-## 1.6.2
-
-* aeson 2.0
-
-## 1.6.1
-
-Added command line options `cert` and `key` to allow TLS certificate and key files to be passed to `yesod devel` [#1717](https://github.com/yesodweb/yesod/pull/1717)
-
-## 1.6.0.6
-
-Fix the `add-handler` subcommand to support both the old default routes filename (`routes`) and the new one (`routes.yesodroutes`) [#1688](https://github.com/yesodweb/yesod/pull/1688)
-
-## 1.6.0.5
-
-* Use process groups to ensure GHC is killed on Ctrl-C [#1683](https://github.com/yesodweb/yesod/pull/1683)
-
-## 1.6.0.4
-
-* Support Cabal 3.0
-
-## 1.6.0.3
-
-* Support Cabal 2.2 [#1151](https://github.com/yesodweb/yesod/issues/1511)
-
-## 1.6.0.2
-
-* Fix broken support for older http-reverse-proxy
-
-## 1.6.0.1
-
-* Support for http-reverse-proxy 0.6
-
-## 1.6.0
-
-* Upgrade to conduit 1.3.0
-* Remove configure, build, touch, and test commands
-
-## 1.5.3
-
-* Support typed-process-0.2.0.0
-
 ## 1.5.2.6
 
 * Drop an upper bound

yesod-bin/Devel.hs

@@ -9,15 +9,18 @@ module Devel
     ) where
 
 import           Control.Applicative                   ((<|>))
-import           UnliftIO                              (race_)
 import           Control.Concurrent                    (threadDelay)
+import           Control.Concurrent.Async              (race_)
 import           Control.Concurrent.STM
-import qualified UnliftIO.Exception                    as Ex
+import qualified Control.Exception.Safe                as Ex
 import           Control.Monad                         (forever, unless, void,
                                                         when)
 import Data.ByteString (ByteString, isInfixOf)
 import qualified Data.ByteString.Lazy                  as LB
-import           Conduit
+import           Data.Conduit                          (($$), (=$))
+import qualified Data.Conduit.Binary                   as CB
+import qualified Data.Conduit.List                     as CL
+import           Data.Default.Class                    (def)
 import           Data.FileEmbed                        (embedFile)
 import qualified Data.Map                              as Map
 import           Data.Maybe                            (isJust)
@@ -28,14 +31,7 @@ import           Data.String                           (fromString)
 import           Data.Time                             (getCurrentTime)
 import qualified Distribution.Package                  as D
 import qualified Distribution.PackageDescription       as D
-#if MIN_VERSION_Cabal(3,8,0)
-import qualified Distribution.Simple.PackageDescription as D
-#endif
-#if MIN_VERSION_Cabal(2, 2, 0)
-import qualified Distribution.PackageDescription.Parsec as D
-#else
 import qualified Distribution.PackageDescription.Parse as D
-#endif
 import qualified Distribution.Simple.Utils             as D
 import qualified Distribution.Verbosity                as D
 import           Network.HTTP.Client                   (newManager)
@@ -44,13 +40,7 @@ import           Network.HTTP.Client                   (managerSetProxy,
 import           Network.HTTP.Client.TLS               (tlsManagerSettings)
 import           Network.HTTP.ReverseProxy             (ProxyDest (ProxyDest),
                                                         waiProxyToSettings,
-                                                        wpsOnExc, wpsTimeout,
+                                                        wpsOnExc, wpsTimeout)
-#if MIN_VERSION_http_reverse_proxy(0, 6, 0)
-                                                        defaultWaiProxySettings
-#else
-                                                        def
-#endif
-                                                        )
 import qualified Network.HTTP.ReverseProxy             as ReverseProxy
 import           Network.HTTP.Types                    (status200, status503)
 import qualified Network.Socket
@@ -59,7 +49,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
@@ -71,7 +61,7 @@ import           System.FilePath                       (takeDirectory,
 import           System.FSNotify
 import           System.IO                             (stdout, stderr)
 import           System.IO.Error                       (isDoesNotExistError)
-import           Data.Conduit.Process.Typed
+import           System.Process.Typed
 
 -- We have two special files:
 --
@@ -129,7 +119,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 +128,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) =
@@ -160,11 +149,7 @@ reverseProxy opts appPortVar = do
                     return $
                         ReverseProxy.WPRProxyDest
                         $ ProxyDest "127.0.0.1" appPort)
-#if MIN_VERSION_http_reverse_proxy(0, 6, 0)
-                defaultWaiProxySettings
-#else
                 def
-#endif
                     { wpsOnExc = \e req f -> onExc e req >>= f
                     , wpsTimeout =
                         if proxyTimeout opts == 0
@@ -174,12 +159,10 @@ reverseProxy opts appPortVar = do
                 manager
         defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings
         runProxyTls port app = do
-          let certDef = $(embedFile "certificate.pem")
+          let cert = $(embedFile "certificate.pem")
-              keyDef = $(embedFile "key.pem")
+              key = $(embedFile "key.pem")
-              theSettings = case cert opts of
+              tlsSettings = tlsSettingsMemory cert key
-                Nothing -> tlsSettingsMemory certDef keyDef
+          runTLS tlsSettings (setPort port defaultSettings') $ \req send -> do
-                Just (c,k) -> tlsSettings c k
-          runTLS theSettings (setPort port defaultSettings') $ \req send -> do
             let req' = req
                     { requestHeaders
                         = ("X-Forwarded-Proto", "https")
@@ -292,9 +275,7 @@ devel opts passThroughArgs = do
 
     -- Find out the name of our package, needed for the upcoming Stack
     -- commands
-#if MIN_VERSION_Cabal(3, 0, 0)
+#if MIN_VERSION_Cabal(1, 20, 0)
-    cabal  <- D.tryFindPackageDesc D.silent "."
-#elif MIN_VERSION_Cabal(1, 20, 0)
     cabal  <- D.tryFindPackageDesc "."
 #else
     cabal  <- D.findPackageDesc "."
@@ -351,8 +332,7 @@ devel opts passThroughArgs = do
         myPath <- getExecutablePath
         let procConfig = setStdout createSource
                        $ setStderr createSource
-                       $ setCreateGroup True -- because need when yesod-bin killed and kill child ghc
+                       $ setDelegateCtlc True $ proc "stack" $
-                       $ proc "stack" $
                 [ "build"
                 , "--fast"
                 , "--file-watch"
@@ -388,10 +368,9 @@ devel opts passThroughArgs = do
         -- process is piped to the actual stdout and stderr handles.
         withProcess_ procConfig $ \p -> do
             let helper getter h =
-                      runConduit
+                      getter p
-                    $ getter p
+                   $$ CL.iterM (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
-                   .| iterMC (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
+                   =$ CB.sinkHandle h
-                   .| sinkHandle h
             race_ (helper getStdout stdout) (helper getStderr stderr)
 
     -- Run the inner action with a TVar which will be set to True

yesod-bin/HsFile.hs

@@ -2,17 +2,20 @@
 {-# LANGUAGE OverloadedStrings #-}
 module HsFile (mkHsFile) where
 import Text.ProjectTemplate (createTemplate)
-import Conduit
+import Data.Conduit 
+    ( ($$), (=$), awaitForever)
+import Data.Conduit.Filesystem (sourceDirectory)
+import Control.Monad.Trans.Resource (runResourceT)
+import qualified Data.Conduit.List as CL
 import qualified Data.ByteString as BS
 import Control.Monad.IO.Class (liftIO)
 import Data.String (fromString)
 
 mkHsFile :: IO ()
-mkHsFile = runConduitRes
+mkHsFile = runResourceT $ sourceDirectory "."
-         $ sourceDirectory "."
+        $$ readIt
-        .| readIt
+        =$ createTemplate 
-        .| createTemplate
+        =$ awaitForever (liftIO . BS.putStr)
-        .| mapM_C (liftIO . BS.putStr)
   where
     -- Reads a filepath from upstream and dumps a pair of (filepath, filecontents)
-    readIt = mapC $ \i -> (fromString i, liftIO $ BS.readFile i)
+    readIt = CL.map $ \i -> (fromString i, liftIO $ BS.readFile i)

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
@@ -104,7 +103,7 @@ to jump through the hoops implied above.
 
 One important note: I highly recommend putting _all_ of the logic in
 your library, and then providing a `develMain :: IO ()` function which
-your `app/devel.hs` script reexports as `main`. I've found this to
+yoru `app/devel.hs` script reexports as `main`. I've found this to
 greatly simplify things overall, since you can ensure all of your
 dependencies are specified correctly in your `.cabal` file. Also, I
 recommend using `PackageImports` in that file, as the example app

yesod-bin/main.hs

@@ -2,18 +2,37 @@
 {-# LANGUAGE RecordWildCards             #-}
 module Main (main) where
 
+import           Control.Monad          (unless)
 import           Data.Monoid
 import           Data.Version           (showVersion)
 import           Options.Applicative
-import           System.Exit            (exitFailure)
+import           System.Environment     (getEnvironment)
+import           System.Exit            (ExitCode (ExitSuccess), exitWith, exitFailure)
+import           System.Process         (rawSystem)
 
 import           AddHandler             (addHandler)
 import           Devel                  (DevelOpts (..), devel, develSignal)
 import           Keter                  (keter)
 import           Options                (injectDefaults)
 import qualified Paths_yesod_bin
+import           System.IO              (hPutStrLn, stderr)
 
 import           HsFile                 (mkHsFile)
+#ifndef WINDOWS
+import           Build                  (touch)
+
+touch' :: IO ()
+touch' = touch
+
+windowsWarning :: String
+windowsWarning = ""
+#else
+touch' :: IO ()
+touch'  = return ()
+
+windowsWarning :: String
+windowsWarning = " (does not work on Windows)"
+#endif
 
 data CabalPgm = Cabal | CabalDev deriving (Show, Eq)
 
@@ -30,13 +49,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
@@ -73,16 +91,17 @@ main = do
                     c -> c
                 })
          ] optParser'
+  let cabal = rawSystem' (cabalCommand o)
   case optCommand o of
     Init _          -> initErrorMsg
     HsFiles         -> mkHsFile
-    Configure       -> cabalErrorMsg
+    Configure       -> cabal ["configure"]
-    Build _         -> cabalErrorMsg
+    Build es        -> touch' >> cabal ("build":es)
-    Touch           -> cabalErrorMsg
+    Touch           -> touch'
     Keter{..}       -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs
     Version         -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
     AddHandler{..}  -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods
-    Test            -> cabalErrorMsg
+    Test            -> cabalTest cabal
     Devel{..}       -> devel DevelOpts
                              { verbose      = optVerbose o
                              , successHook  = develSuccessHook
@@ -91,10 +110,22 @@ main = do
                              , proxyTimeout = proxyTimeout
                              , useReverseProxy = not noReverseProxy
                              , develHost    = develHost
-                             , cert         = cert
                              } develExtraArgs
     DevelSignal     -> develSignal
   where
+    cabalTest cabal = do
+        env <- getEnvironment
+        case lookup "STACK_EXE" env of
+            Nothing -> do
+                touch'
+                _ <- cabal ["configure", "--enable-tests", "-flibrary-only"]
+                _ <- cabal ["build"]
+                cabal ["test"]
+            Just _ -> do
+                hPutStrLn stderr "'yesod test' is no longer needed with Stack"
+                hPutStrLn stderr "Instead, please just run 'stack test'"
+                exitFailure
+
     initErrorMsg = do
         mapM_ putStrLn
             [ "The init command has been removed."
@@ -105,13 +136,6 @@ main = do
             ]
         exitFailure
 
-    cabalErrorMsg = do
-        mapM_ putStrLn
-            [ "The configure, build, touch, and test commands have been removed."
-            , "Please use 'stack' for building your project."
-            ]
-        exitFailure
-
 optParser' :: ParserInfo Options
 optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
 
@@ -124,17 +148,17 @@ optParser = Options
                       <> command "hsfiles" (info (pure HsFiles)
                             (progDesc "Create a hsfiles file for the current folder"))
                       <> command "configure" (info (pure Configure)
-                            (progDesc "DEPRECATED"))
+                            (progDesc "Configure a project for building"))
                       <> command "build"     (info (helper <*> (Build <$> extraCabalArgs))
-                            (progDesc "DEPRECATED"))
+                            (progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning))
                       <> command "touch"     (info (pure Touch)
-                            (progDesc "DEPRECATED"))
+                            (progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning))
                       <> command "devel"     (info (helper <*> develOptions)
                             (progDesc "Run project with the devel server"))
                       <> command "devel-signal"     (info (helper <*> pure DevelSignal)
                             (progDesc "Used internally by the devel command"))
                       <> command "test"      (info (pure Test)
-                            (progDesc "DEPRECATED"))
+                            (progDesc "Build and run the integration tests"))
                       <> command "add-handler" (info (helper <*> addHandlerOptions)
                             (progDesc ("Add a new handler and module to the project."
                             ++ " Interactively asks for input if you do not specify arguments.")))
@@ -169,11 +193,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"
@@ -198,3 +217,10 @@ addHandlerOptions = AddHandler
 -- | Optional @String@ argument
 optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
 optStr m = option (Just <$> str) $ value Nothing <> m
+
+-- | Like @rawSystem@, but exits if it receives a non-success result.
+rawSystem' :: String -> [String] -> IO ()
+rawSystem' x y = do
+    res <- rawSystem x y
+    unless (res == ExitSuccess) $ exitWith res
+

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.6.2.2
+version:         1.5.2.6
 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,53 +19,64 @@ 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
+                     , parsec             >= 2.1          && < 4
-                     , bytestring         >= 0.9.1.4
-                     , conduit            >= 1.3
-                     , conduit-extra      >= 1.3
-                     , containers         >= 0.2
-                     , data-default-class
-                     , directory          >= 1.2.1
-                     , file-embed
-                     , filepath           >= 1.1
-                     , fsnotify
-                     , http-client        >= 0.4.7
-                     , http-client-tls
-                     , http-reverse-proxy >= 0.4
-                     , http-types         >= 0.7
-                     , network            >= 2.5
-                     , optparse-applicative >= 0.11
-                     , process
-                     , project-template   >= 0.1.1
-                     , say
-                     , split              >= 0.2          && < 0.3
-                     , stm
-                     , streaming-commons
-                     , tar                >= 0.4          && < 0.6
                      , text               >= 0.11
+                     , shakespeare        >= 2.0
+                     , bytestring         >= 0.9.1.4
                      , time               >= 1.1.4
+                     , template-haskell
+                     , directory          >= 1.2.1
+                     , Cabal              >= 1.18
+                     , unix-compat        >= 0.2
+                     , containers         >= 0.2
+                     , attoparsec         >= 0.10
+                     , http-types         >= 0.7
+                     , blaze-builder      >= 0.2.1.4      && < 0.5
+                     , filepath           >= 1.1
+                     , process
+                     , zlib               >= 0.5
+                     , tar                >= 0.4          && < 0.6
+                     , unordered-containers
+                     , yaml               >= 0.8          && < 0.9
+                     , optparse-applicative >= 0.11
+                     , fsnotify           >= 0.0          && < 0.3
+                     , split              >= 0.2          && < 0.3
+                     , file-embed
+                     , conduit            >= 1.2
+                     , conduit-extra
+                     , resourcet          >= 0.3          && < 1.2
+                     , base64-bytestring
+                     , lifted-base
+                     , http-reverse-proxy >= 0.4
+                     , network            >= 2.5
+                     , http-client-tls
+                     , http-client        >= 0.4.7
+                     , project-template   >= 0.1.1
+                     , safe-exceptions
+                     , say
+                     , stm
                      , transformers
                      , transformers-compat
-                     , unliftio
+                     , warp               >= 1.3.7.5
-                     , unordered-containers
                      , wai                >= 2.0
                      , wai-extra
-                     , warp               >= 1.3.7.5
+                     , data-default-class
+                     , streaming-commons
                      , warp-tls           >= 3.0.1
-                     , yaml               >= 0.8          && < 0.12
+                     , async
-                     , zlib               >= 0.5
+                     , deepseq
-                     , aeson
+                     , typed-process
 
     ghc-options:       -Wall -threaded -rtsopts
     main-is:           main.hs
     other-modules:     Devel
+                       Build
                        Keter
                        AddHandler
                        Paths_yesod_bin

yesod-core/ChangeLog.md

@@ -1,242 +1,3 @@
-# ChangeLog for yesod-core
-
-## 1.6.25.1
-
-* Export the options that were created in 1.6.25.0 [#1825](https://github.com/yesodweb/yesod/pull/1825)
-
-## 1.6.25.0
-
-* Add an options structure that allows the user to set which instances will be derived for a routes structure. [#1819](https://github.com/yesodweb/yesod/pull/1819)
-
-## 1.6.24.5
-
-* Support Aeson 2.2 [#1818](https://github.com/yesodweb/yesod/pull/1818)
-
-## 1.6.24.4
-
-* Fix test-suite compilation error for GHC >= 9.0.1 [#1812](https://github.com/yesodweb/yesod/pull/1812)
-
-## 1.6.24.3
-
-* Fix subsite-to-subsite dispatch [#1805](https://github.com/yesodweb/yesod/pull/1805)
-
-## 1.6.24.2
-
-* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
-
-## 1.6.24.1
-
-* Adapt to removal of `ListT` from transformers-0.6. [#1796](https://github.com/yesodweb/yesod/pull/1796)
-
-## 1.6.24.0
-
-* Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772).
-
-## 1.6.23.1
-
-* Fix typo in creation of the description `<meta>` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766)
-
-## 1.6.23
-
-* Add idempotent versions of `setDescription`, `setDescriptionI`. These functions
-  have odd behaviour when called multiple times, so they are now warned against.
-  This can't be a silent change - if you want to switch to the new functions, make
-  sure your layouts are updated to use `pageDescription` as well as `pageTitle`.
-  [#1765](https://github.com/yesodweb/yesod/pull/1765)
-
-## 1.6.22.1
-
-+ Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756)
-
-## 1.6.22.0
-
-* Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745)
-* Add instances for `ToContent Void`, `ToTypedContent Void`. [#1752](https://github.com/yesodweb/yesod/pull/1752)
-* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753)
-* Support template-haskell 2.18 [#1754](https://github.com/yesodweb/yesod/pull/1754)
-
-## 1.6.21.0
-
-* Export `Yesod.Core.Dispatch.defaultGen` so that users may reuse it for their own `YesodRunnerEnv`s [#1734](https://github.com/yesodweb/yesod/pull/1734)
-
-## 1.6.20.2
-
-* Fix compatibility with template-haskell 2.17 [#1729](https://github.com/yesodweb/yesod/pull/1729)
-
-## 1.6.20.1
-
-* Throw an error in `breadcrumbs` if the trail of breadcrumbs is circular. [#1727](https://github.com/yesodweb/yesod/issues/1727)
-
-## 1.6.20
-
-* Generate CSRF tokens using a secure entropy source [#1726](https://github.com/yesodweb/yesod/pull/1726)
-* Change semantics of `yreGen` and `defaultGen`
-
-## 1.6.19.0
-
-* Change order of priority in `languages`[#1721](https://github.com/yesodweb/yesod/pull/1721)
-
-## 1.6.18.8
-
-* Fix test suite for wai-extra change around vary header
-
-## 1.6.18.7
-
-* Fix functions generating Open Graph metadata[#1709](https://github.com/yesodweb/yesod/pull/1709)
-
-## 1.6.18.6
-
-* Update documentation from `HandlerT` to `HandlerFor` [#1703](https://github.com/yesodweb/yesod/pull/1703)
-
-## 1.6.18.5
-
-Document `ErrorResponse` [#1698](https://github.com/yesodweb/yesod/pull/1698)
-
-## 1.6.18.4
-
-* Fixed a bug where `mkYesod` and other TH functions didn't work for datatypes with explicitly stated type variables, including the case with typeclass constraints. [https://github.com/yesodweb/yesod/pull/1697](#1697)
-
-## 1.6.18.3
-
-* Remove mention of an oudated Yesod type (`GHandler`) from the docs for `handlerToIO`. [https://github.com/yesodweb/yesod/pull/1695](#1695)
-
-## 1.6.18.2
-
-* Recommends `.yesodroutes` as the file extension for Yesod routes files. [#1686](https://github.com/yesodweb/yesod/pull/1686)
-
-## 1.6.18.1
-
-* Increase the size of CSRF token
-
-## 1.6.18
-
-* Add functions for setting description and OG meta [#1663](https://github.com/yesodweb/yesod/pull/1663)
-
-* Use `DeriveLift` to implement the `Lift` instances for `ResourceTree`,
-  `Resource`, `Piece`, and `Dispatch`. Among other benefits, this provides
-  implementations of `liftTyped` on `template-haskell-2.16` (GHC 8.10) or
-  later. [#1664](https://github.com/yesodweb/yesod/pull/1664)
-
-## 1.6.17.3
-
-* Support for `unliftio-core` 0.2
-
-## 1.6.17.2
-
-* Support template-haskell 2.16, build with GHC 8.10 [#1657](https://github.com/yesodweb/yesod/pull/1657)
-
-## 1.6.17.1
-
-* Remove unnecessary deriving of Typeable
-
-## 1.6.17
-
-* Adds `contentTypeIsJson` [#1646](https://github.com/yesodweb/yesod/pull/1646)
-
-## 1.6.16.1
-
-* Compiles with GHC 8.8.1
-
-## 1.6.16
-
-* Add `jsAttributesHandler` to run arbitrary Handler code before building the
-  attributes map for the script tag generated by `widgetFile` [#1622](https://github.com/yesodweb/yesod/pull/1622)
-
-## 1.6.15
-
-* Move `redirectToPost` JavaScript form submission from HTML element to
-  `<script>` tag for CSP reasons [#1620](https://github.com/yesodweb/yesod/pull/1620)
-
-## 1.6.14
-
-* Introduce `JSONResponse`. [issue #1481](https://github.com/yesodweb/yesod/issues/1481) and [PR #1592](https://github.com/yesodweb/yesod/pull/1592)
-
-## 1.6.13
-
-* Introduce `maxContentLengthIO`. [issue #1588](https://github.com/yesodweb/yesod/issues/1588) and [PR #1589](https://github.com/yesodweb/yesod/pull/1589)
-
-## 1.6.12
-
-* Use at most one valid session cookie per request [#1581](https://github.com/yesodweb/yesod/pull/1581)
-
-## 1.6.11
-
-* Deprecate insecure JSON parsing functions [#1576](https://github.com/yesodweb/yesod/pull/1576)
-
-## 1.6.10.1
-
-* Fix test suite compilation for [commercialhaskell/stackage#4319](https://github.com/commercialhaskell/stackage/issues/4319)
-
-## 1.6.10
-
-* Adds functions to get and set values in the per-request caches. [#1573](https://github.com/yesodweb/yesod/pull/1573)
-
-## 1.6.9
-
-* Add `sendResponseNoContent` [#1565](https://github.com/yesodweb/yesod/pull/1565)
-
-## 1.6.8.1
-
-* Add missing test file to tarball [#1563](https://github.com/yesodweb/yesod/issues/1563)
-
-## 1.6.8
-* In the route syntax, allow trailing backslashes to indicate line
-    continuation. [#1558](https://github.com/yesodweb/yesod/pull/1558)
-
-## 1.6.7
-
-* If no matches are found, `selectRep` chooses first representation regardless
-    of the presence or absence of a `Content-Type` header in the request
-    [#1540](https://github.com/yesodweb/yesod/pull/1540)
-* Sets the `X-XSS-Protection` header to `1; mode=block` [#1550](https://github.com/yesodweb/yesod/pull/1550)
-* Add `PrimMonad` instances for `HandlerFor` and `WidgetFor` [from
-  StackOverflow](https://stackoverflow.com/q/52692508/369198)
-
-## 1.6.6
-
-* `defaultErrorHandler` handles text/plain requests [#1522](https://github.com/yesodweb/yesod/pull/1520)
-
-## 1.6.5
-
-* Add `fileSourceByteString` [#1503](https://github.com/yesodweb/yesod/pull/1503)
-
-## 1.6.4
-
-* Add `addContentDispositionFileName` [#1504](https://github.com/yesodweb/yesod/pull/1504)
-
-## 1.6.3
-
-* Add missing export for `SubHandlerFor`
-
-## 1.6.2
-
-* Derive a `Show` instance for `ResourceTree` and `FlatResource` [#1492](https://github.com/yesodweb/yesod/pull/1492)
-	* Some third party packages, like `yesod-routes-flow` derive their own `Show` instance, and this will break those packages.
-
-## 1.6.1
-
-* Add a `Semigroup LiteApp` instance, and explicitly define `(<>)` in the
-  already existing `Semigroup` instances for `WidgetFor`, `Head`, `Body`,
-  `GWData`, and `UniqueList`.
-
-## 1.6.0
-
-* Upgrade to conduit 1.3.0
-* Switch to `MonadUnliftIO`
-* Drop `mwc-random` and `blaze-builder` dependencies
-* Strictify some internal data structures
-* Add `CI` wrapper to first field in `Header` data constructor
-  [#1418](https://github.com/yesodweb/yesod/issues/1418)
-* Internal only change, users of stable API are unaffected: `WidgetT`
-  holds its data in an `IORef` so that it is isomorphic to `ReaderT`,
-  avoiding state-loss issues..
-* Overhaul of `HandlerT`/`WidgetT` to no longer be transformers.
-* Fix Haddock comment & simplify implementation for `contentTypeTypes` [#1476](https://github.com/yesodweb/yesod/issues/1476)
-
-## 1.4.37.3
-
-* Improve error message when request body is too large [#1477](https://github.com/yesodweb/yesod/pull/1477)
-
 ## 1.4.37.2
 
 * Improve error messages for the CSRF checking functions [#1455](https://github.com/yesodweb/yesod/issues/1455)

yesod-core/Yesod/Core.hs

@@ -31,6 +31,7 @@ module Yesod.Core
       -- * Logging
     , defaultMakeLogger
     , defaultMessageLoggerSource
+    , defaultShouldLog
     , defaultShouldLogIO
     , formatLogMessage
     , LogLevel (..)
@@ -66,9 +67,11 @@ module Yesod.Core
     -- * JS loaders
     , ScriptLoadPosition (..)
     , BottomOfHeadAsync
-    -- * Generalizing type classes
+      -- * Subsites
     , MonadHandler (..)
     , MonadWidget (..)
+    , getRouteToParent
+    , defaultLayoutSub
       -- * Approot
     , guessApproot
     , guessApprootOr
@@ -92,7 +95,8 @@ module Yesod.Core
     , module Text.Blaze.Html
     , MonadTrans (..)
     , MonadIO (..)
-    , MonadUnliftIO (..)
+    , MonadBase (..)
+    , MonadBaseControl
     , MonadResource (..)
     , MonadLogger
       -- * Commonly referenced functions/datatypes
@@ -139,7 +143,9 @@ import qualified Yesod.Core.Internal.Run
 import qualified Paths_yesod_core
 import Data.Version (showVersion)
 import Yesod.Routes.Class
-import UnliftIO (MonadIO (..), MonadUnliftIO (..))
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Base (MonadBase (..))
+import Control.Monad.Trans.Control (MonadBaseControl (..))
 
 import Control.Monad.Trans.Resource (MonadResource (..))
 import Yesod.Core.Internal.LiteApp
@@ -179,6 +185,14 @@ maybeAuthorized r isWrite = do
     x <- isAuthorized r isWrite
     return $ if x == Authorized then Just r else Nothing
 
+getRouteToParent :: Monad m => HandlerT child (HandlerT parent m) (Route child -> Route parent)
+getRouteToParent = HandlerT $ return . handlerToParent
+
+defaultLayoutSub :: Yesod parent
+                 => WidgetT child IO ()
+                 -> HandlerT child (HandlerT parent IO) Html
+defaultLayoutSub cwidget = widgetToParentWidget cwidget >>= lift . defaultLayout
+
 showIntegral :: Integral a => a -> String
 showIntegral x = show (fromIntegral x :: Integer)
 

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

@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
 module Yesod.Core.Class.Breadcrumbs where
 
 import Yesod.Core.Handler
@@ -12,11 +11,11 @@ import Data.Text (Text)
 class YesodBreadcrumbs site where
     -- | Returns the title and the parent resource, if available. If you return
     -- a 'Nothing', then this is considered a top-level page.
-    breadcrumb :: Route site -> HandlerFor site (Text , Maybe (Route site))
+    breadcrumb :: Route site -> HandlerT site IO (Text , Maybe (Route site))
 
 -- | 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 => HandlerT site IO (Text, [(Route site, Text)])
 breadcrumbs = do
     x <- getCurrentRoute
     case x of
@@ -27,8 +26,6 @@ breadcrumbs = do
             return (title, z)
   where
     go back Nothing = return back
-    go back (Just this)
+    go back (Just this) = do
-      | this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this
+        (title, next) <- breadcrumb this
-      | otherwise = do
+        go ((this, title) : back) next
-          (title, next) <- breadcrumb this
-          go ((this, title) : back) next

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

@@ -0,0 +1,51 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts  #-}
+module Yesod.Core.Class.Dispatch where
+
+import Yesod.Routes.Class
+import qualified Network.Wai as W
+import Yesod.Core.Types
+import Yesod.Core.Content
+import Yesod.Core.Handler (sendWaiApplication, stripHandlerT)
+import Yesod.Core.Class.Yesod
+import Yesod.Core.Class.Handler
+
+-- | This class is automatically instantiated when you use the template haskell
+-- mkYesod function. You should never need to deal with it directly.
+class Yesod site => YesodDispatch site where
+    yesodDispatch :: YesodRunnerEnv site -> W.Application
+
+class YesodSubDispatch sub m where
+    yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m
+                     -> W.Application
+
+instance YesodSubDispatch WaiSubsite master where
+    yesodSubDispatch YesodSubRunnerEnv {..} = app
+      where
+        WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
+
+instance YesodSubDispatch WaiSubsiteWithAuth (HandlerT master IO) where
+  yesodSubDispatch YesodSubRunnerEnv {..} req =
+      ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req
+    where
+      base  = stripHandlerT handlert ysreGetSub ysreToParentRoute route
+      route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []
+      WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
+      handlert = sendWaiApplication $ set
+
+-- | A helper function for creating YesodSubDispatch instances, used by the
+-- internal generated code. This function has been exported since 1.4.11.
+-- It promotes a subsite handler to a wai application.
+subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained.
+          => HandlerT child (HandlerT parent m) TypedContent
+          -> YesodSubRunnerEnv child parent (HandlerT parent m)
+          -> Maybe (Route child)
+          -> W.Application
+subHelper handlert YesodSubRunnerEnv {..} route =
+    ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)
+  where
+    base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route

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

@@ -0,0 +1,95 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Because of ErrorT
+module Yesod.Core.Class.Handler
+    ( MonadHandler (..)
+    , MonadWidget (..)
+    ) where
+
+import Yesod.Core.Types
+import Control.Monad (liftM)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase)
+import Control.Monad.Trans.Class (lift)
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid (Monoid, mempty)
+#endif
+import Data.Conduit.Internal (Pipe, ConduitM)
+
+import Control.Monad.Trans.Identity ( IdentityT)
+import Control.Monad.Trans.List     ( ListT    )
+import Control.Monad.Trans.Maybe    ( MaybeT   )
+import Control.Monad.Trans.Error    ( ErrorT, Error)
+import Control.Monad.Trans.Except   ( ExceptT  )
+import Control.Monad.Trans.Reader   ( ReaderT  )
+import Control.Monad.Trans.State    ( StateT   )
+import Control.Monad.Trans.Writer   ( WriterT  )
+import Control.Monad.Trans.RWS      ( RWST     )
+import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )
+import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )
+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
+
+class MonadResource m => MonadHandler m where
+    type HandlerSite m
+    liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a
+
+replaceToParent :: HandlerData site route -> HandlerData site ()
+replaceToParent hd = hd { handlerToParent = const () }
+
+instance MonadResourceBase m => MonadHandler (HandlerT site m) where
+    type HandlerSite (HandlerT site m) = site
+    liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent
+{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-}
+
+instance MonadResourceBase m => MonadHandler (WidgetT site m) where
+    type HandlerSite (WidgetT site m) = site
+    liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent
+{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-}
+
+#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
+#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
+GO(IdentityT)
+GO(ListT)
+GO(MaybeT)
+GOX(Error e, ErrorT e)
+GO(ExceptT e)
+GO(ReaderT r)
+GO(StateT s)
+GOX(Monoid w, WriterT w)
+GOX(Monoid w, RWST r w s)
+GOX(Monoid w, Strict.RWST r w s)
+GO(Strict.StateT s)
+GOX(Monoid w, Strict.WriterT w)
+GO(Pipe l i o u)
+GO(ConduitM i o)
+#undef GO
+#undef GOX
+
+class MonadHandler m => MonadWidget m where
+    liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
+instance MonadResourceBase m => MonadWidget (WidgetT site m) where
+    liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent
+
+#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
+#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
+GO(IdentityT)
+GO(ListT)
+GO(MaybeT)
+GOX(Error e, ErrorT e)
+GO(ExceptT e)
+GO(ReaderT r)
+GO(StateT s)
+GOX(Monoid w, WriterT w)
+GOX(Monoid w, RWST r w s)
+GOX(Monoid w, Strict.RWST r w s)
+GO(Strict.StateT s)
+GOX(Monoid w, Strict.WriterT w)
+GO(Pipe l i o u)
+GO(ConduitM i o)
+#undef GO
+#undef GOX

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

@@ -1,9 +1,8 @@
-{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP               #-}
-
 module Yesod.Core.Class.Yesod where
 
 import           Yesod.Core.Content
@@ -11,10 +10,14 @@ import           Yesod.Core.Handler
 
 import           Yesod.Routes.Class
 
-import           Data.ByteString.Builder            (Builder)
+import           Blaze.ByteString.Builder           (Builder, toByteString)
-import           Data.Text.Encoding                 (encodeUtf8Builder)
+import           Blaze.ByteString.Builder.ByteString (copyByteString)
+import           Blaze.ByteString.Builder.Char.Utf8 (fromText, fromChar)
 import           Control.Arrow                      ((***), second)
 import           Control.Exception                  (bracket)
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative                ((<$>))
+#endif
 import           Control.Monad                      (forM, when, void)
 import           Control.Monad.IO.Class             (MonadIO (liftIO))
 import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelOther),
@@ -25,7 +28,6 @@ import qualified Data.ByteString.Lazy               as L
 import Data.Aeson (object, (.=))
 import           Data.List                          (foldl', nub)
 import qualified Data.Map                           as Map
-import           Data.Maybe                         (catMaybes)
 import           Data.Monoid
 import           Data.Text                          (Text)
 import qualified Data.Text                          as T
@@ -35,8 +37,9 @@ import           Data.Text.Lazy.Builder             (toLazyText)
 import           Data.Text.Lazy.Encoding            (encodeUtf8)
 import           Data.Word                          (Word64)
 import           Language.Haskell.TH.Syntax         (Loc (..))
-import           Network.HTTP.Types                 (encodePath)
+import           Network.HTTP.Types                 (encodePath, renderQueryText)
 import qualified Network.Wai                        as W
+import           Data.Default                       (def)
 import           Network.Wai.Parse                  (lbsBackEnd,
                                                      tempFileBackEnd)
 import           Network.Wai.Logger                 (ZonedDate, clockDateCacher)
@@ -49,15 +52,13 @@ import           Text.Hamlet
 import           Text.Julius
 import qualified Web.ClientSession                  as CS
 import           Web.Cookie                         (SetCookie (..), parseCookies, sameSiteLax,
-                                                     sameSiteStrict, SameSiteOption, defaultSetCookie)
+                                                     sameSiteStrict, SameSiteOption)
 import           Yesod.Core.Types
 import           Yesod.Core.Internal.Session
 import           Yesod.Core.Widget
+import Control.Monad.Trans.Class (lift)
 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.
@@ -65,33 +66,27 @@ class RenderRoute site => Yesod site where
     -- | An absolute URL to the root of the application. Do not include
     -- trailing slash.
     --
-    -- Default value: 'guessApproot'. If you know your application root
+    -- Default value: 'ApprootRelative'. This is valid under the following
-    -- statically, it will be more efficient and more reliable to instead use
+    -- conditions:
-    -- 'ApprootStatic' or 'ApprootMaster'. If you do not need full absolute
-    -- URLs, you can use 'ApprootRelative' instead.
     --
-    -- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'.
+    -- * Your application is served from the root of the domain.
+    --
+    -- * You do not use any features that require absolute URLs, such as Atom
+    -- feeds and XML sitemaps.
+    --
+    -- If this is not true, you should override with a different
+    -- implementation.
     approot :: Approot site
-    approot = guessApproot
+    approot = ApprootRelative
-
-    -- | @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'.
-    errorHandler :: ErrorResponse -> HandlerFor site TypedContent
+    errorHandler :: ErrorResponse -> HandlerT site IO TypedContent
     errorHandler = defaultErrorHandler
 
     -- | Applies some form of layout to the contents of a page.
-    defaultLayout :: WidgetFor site () -> HandlerFor site Html
+    defaultLayout :: WidgetT site IO () -> HandlerT site IO Html
     defaultLayout w = do
         p <- widgetToPageContent w
         msgs <- getMessages
@@ -101,8 +96,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
@@ -110,19 +103,33 @@ class RenderRoute site => Yesod site where
                     ^{pageBody p}
             |]
 
+    -- | Override the rendering function for a particular URL. One use case for
+    -- this is to offload static hosting to a different domain name to avoid
+    -- sending cookies.
+    urlRenderOverride :: site -> Route site -> Maybe Builder
+    urlRenderOverride _ _ = Nothing
+
     -- | Override the rendering function for a particular URL and query string
     -- parameters. One use case for this is to offload static hosting to a
     -- different domain name to avoid sending cookies.
-    --
+    -- 
     -- For backward compatibility default implementation is in terms of
     -- 'urlRenderOverride', probably ineffective
-    --
+    -- 
     -- Since 1.4.23
     urlParamRenderOverride :: site
                            -> Route site
                            -> [(T.Text, T.Text)] -- ^ query string
                            -> Maybe Builder
-    urlParamRenderOverride _ _ _ = Nothing
+    urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route
+      where
+        addParams [] routeBldr = routeBldr
+        addParams nonEmptyParams routeBldr =
+            let routeBS = toByteString routeBldr
+                qsSeparator = fromChar $ if S8.elem '?' routeBS then '&' else '?'
+                valueToMaybe t = if t == "" then Nothing else Just t
+                queryText = map (id *** valueToMaybe) nonEmptyParams
+            in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText
 
     -- | Determine if a request is authorized or not.
     --
@@ -131,7 +138,7 @@ class RenderRoute site => Yesod site where
     -- If authentication is required, return 'AuthenticationRequired'.
     isAuthorized :: Route site
                  -> Bool -- ^ is this a write request?
-                 -> HandlerFor site AuthResult
+                 -> HandlerT site IO AuthResult
     isAuthorized _ _ = return Authorized
 
     -- | Determines whether the current request is a write request. By default,
@@ -141,7 +148,7 @@ class RenderRoute site => Yesod site where
     --
     -- This function is used to determine if a request is authorized; see
     -- 'isAuthorized'.
-    isWriteRequest :: Route site -> HandlerFor site Bool
+    isWriteRequest :: Route site -> HandlerT site IO Bool
     isWriteRequest _ = do
         wai <- waiRequest
         return $ W.requestMethod wai `notElem`
@@ -184,7 +191,7 @@ class RenderRoute site => Yesod site where
              -> [(T.Text, T.Text)] -- ^ query string
              -> Builder
     joinPath _ ar pieces' qs' =
-        encodeUtf8Builder ar `mappend` encodePath pieces qs
+        fromText ar `mappend` encodePath pieces qs
       where
         pieces = if null pieces' then [""] else map addDash pieces'
         qs = map (TE.encodeUtf8 *** go) qs'
@@ -207,11 +214,10 @@ class RenderRoute site => Yesod site where
     addStaticContent :: Text -- ^ filename extension
                      -> Text -- ^ mime-type
                      -> L.ByteString -- ^ content
-                     -> HandlerFor site (Maybe (Either Text (Route site, [(Text, Text)])))
+                     -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
     addStaticContent _ _ _ = return Nothing
 
     -- | Maximum allowed length of the request body, in bytes.
-    -- This method may be ignored if 'maximumContentLengthIO' is overridden.
     --
     -- If @Nothing@, no maximum is applied.
     --
@@ -219,18 +225,6 @@ class RenderRoute site => Yesod site where
     maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64
     maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes
 
-    -- | Maximum allowed length of the request body, in bytes. This is similar
-    -- to 'maximumContentLength', but the result lives in @IO@. This allows
-    -- you to dynamically change the maximum file size based on some external
-    -- source like a database or an @IORef@.
-    --
-    -- The default implementation uses 'maximumContentLength'. Future version of yesod will
-    -- remove 'maximumContentLength' and use this method exclusively.
-    --
-    -- @since 1.6.13
-    maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)
-    maximumContentLengthIO a b = pure $ maximumContentLength a b
-
     -- | Creates a @Logger@ to use for log messages.
     --
     -- Note that a common technique (endorsed by the scaffolding) is to create
@@ -265,16 +259,6 @@ class RenderRoute site => Yesod site where
     jsAttributes :: site -> [(Text, Text)]
     jsAttributes _ = []
 
-    -- | Same as @jsAttributes@ but allows you to run arbitrary Handler code
-    --
-    -- This is useful if you need to add a randomised nonce value to the script
-    -- tag generated by @widgetFile@. If this function is overridden then
-    -- @jsAttributes@ is ignored.
-    --
-    -- @since 1.6.16
-    jsAttributesHandler :: HandlerFor site [(Text, Text)]
-    jsAttributesHandler = jsAttributes <$> getYesod
-
     -- | Create a session backend. Returning 'Nothing' disables
     -- sessions. If you'd like to change the way that the session
     -- cookies are created, take a look at
@@ -296,11 +280,22 @@ class RenderRoute site => Yesod site where
 
     -- | Should we log the given log source/level combination.
     --
-    -- Default: the 'defaultShouldLogIO' function.
+    -- Default: the 'defaultShouldLog' function.
+    shouldLog :: site -> LogSource -> LogLevel -> Bool
+    shouldLog _ = defaultShouldLog
+
+    -- | Should we log the given log source/level combination.
+    --
+    -- Note that this is almost identical to @shouldLog@, except the result
+    -- lives in @IO@. This allows you to dynamically alter the logging level of
+    -- your application by having this result depend on, e.g., an @IORef@.
+    --
+    -- The default implementation simply uses @shouldLog@. Future versions of
+    -- Yesod will remove @shouldLog@ and use this method exclusively.
     --
     -- Since 1.2.4
     shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool
-    shouldLogIO _ = defaultShouldLogIO
+    shouldLogIO a b c = return (shouldLog a b c)
 
     -- | A Yesod middleware, which will wrap every handler function. This
     -- allows you to run code before and after a normal handler.
@@ -308,7 +303,7 @@ class RenderRoute site => Yesod site where
     -- Default: the 'defaultYesodMiddleware' function.
     --
     -- Since: 1.1.6
-    yesodMiddleware :: ToTypedContent res => HandlerFor site res -> HandlerFor site res
+    yesodMiddleware :: ToTypedContent res => HandlerT site IO res -> HandlerT site IO res
     yesodMiddleware = defaultYesodMiddleware
 
     -- | How to allocate an @InternalState@ for each request.
@@ -329,7 +324,7 @@ class RenderRoute site => Yesod site where
     -- primarily for wrapping up error messages for better display.
     --
     -- @since 1.4.30
-    defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site ()
+    defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetT site IO ()
     defaultMessageWidget title body = do
         setTitle title
         toWidget
@@ -337,6 +332,7 @@ class RenderRoute site => Yesod site where
                 <h1>#{title}
                 ^{body}
             |]
+{-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-}
 
 -- | Default implementation of 'makeLogger'. Sends to stdout and
 -- automatically flushes on each write.
@@ -373,18 +369,23 @@ defaultMessageLoggerSource ckLoggable logger loc source level msg = do
 -- above 'LevelInfo'.
 --
 -- Since 1.4.10
+defaultShouldLog :: LogSource -> LogLevel -> Bool
+defaultShouldLog _ level = level >= LevelInfo
+
+-- | A default implementation of 'shouldLogIO' that can be used with
+-- 'defaultMessageLoggerSource'. Just uses 'defaultShouldLog'.
+--
+-- Since 1.4.10
 defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool
-defaultShouldLogIO _ level = return $ level >= LevelInfo
+defaultShouldLogIO a b = return $ defaultShouldLog a b
 
 -- | Default implementation of 'yesodMiddleware'. Adds the response header
--- \"Vary: Accept, Accept-Language\", \"X-XSS-Protection: 1; mode=block\", and
+-- \"Vary: Accept, Accept-Language\" and performs authorization checks.
--- performs authorization checks.
 --
 -- Since 1.2.0
-defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
+defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
 defaultYesodMiddleware handler = do
     addHeader "Vary" "Accept, Accept-Language"
-    addHeader "X-XSS-Protection" "1; mode=block"
     authorizationCheck
     handler
 
@@ -442,8 +443,8 @@ sameSiteSession s = (fmap . fmap) secureSessionCookies
 --
 -- Since 1.4.7
 sslOnlyMiddleware :: Int -- ^ minutes
-                  -> HandlerFor site res
+                  -> HandlerT site IO res
-                  -> HandlerFor site res
+                  -> HandlerT site IO res
 sslOnlyMiddleware timeout handler = do
     addHeader "Strict-Transport-Security"
               $ T.pack $ concat [ "max-age="
@@ -456,7 +457,7 @@ sslOnlyMiddleware timeout handler = do
 -- 'isWriteRequest'.
 --
 -- Since 1.2.0
-authorizationCheck :: Yesod site => HandlerFor site ()
+authorizationCheck :: Yesod site => HandlerT site IO ()
 authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
   where
     checkUrl url = do
@@ -480,7 +481,7 @@ authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
 -- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
 --
 -- Since 1.4.14
-defaultCsrfCheckMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
+defaultCsrfCheckMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
 defaultCsrfCheckMiddleware handler =
     csrfCheckMiddleware
         handler
@@ -494,11 +495,11 @@ defaultCsrfCheckMiddleware handler =
 -- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".
 --
 -- Since 1.4.14
-csrfCheckMiddleware :: HandlerFor site res
+csrfCheckMiddleware :: HandlerT site IO res
-                    -> HandlerFor site Bool -- ^ Whether or not to perform the CSRF check.
+                    -> HandlerT site IO Bool -- ^ Whether or not to perform the CSRF check.
                     -> CI S8.ByteString -- ^ The header name to lookup the CSRF token from.
                     -> Text -- ^ The POST parameter name to lookup the CSRF token from.
-                    -> HandlerFor site res
+                    -> HandlerT site IO res
 csrfCheckMiddleware handler shouldCheckFn headerName paramName = do
     shouldCheck <- shouldCheckFn
     when shouldCheck (checkCsrfHeaderOrParam headerName paramName)
@@ -509,7 +510,7 @@ csrfCheckMiddleware handler shouldCheckFn headerName paramName = do
 -- The cookie's path is set to @/@, making it valid for your whole website.
 --
 -- Since 1.4.14
-defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res
+defaultCsrfSetCookieMiddleware :: HandlerT site IO res -> HandlerT site IO res
 defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler
 
 -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'.
@@ -519,14 +520,14 @@ defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler
 -- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.
 --
 -- Since 1.4.14
-csrfSetCookieMiddleware :: HandlerFor site res -> SetCookie -> HandlerFor site res
+csrfSetCookieMiddleware :: HandlerT site IO res -> SetCookie -> HandlerT site IO res
 csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler
 
 -- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'.
 --
 -- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".
 --
--- You can chain this middleware together with other middleware like so:
+-- You can add this chain this middleware together with other middleware like so:
 --
 -- @
 -- 'yesodMiddleware' = 'defaultYesodMiddleware' . 'defaultCsrfMiddleware'
@@ -539,29 +540,21 @@ csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handl
 -- @
 --
 -- Since 1.4.14
-defaultCsrfMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
+defaultCsrfMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
 defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware
 
 -- | Convert a widget to a 'PageContent'.
 widgetToPageContent :: Yesod site
-                    => WidgetFor site ()
+                    => WidgetT site IO ()
-                    -> HandlerFor site (PageContent (Route site))
+                    -> HandlerT site IO (PageContent (Route site))
 widgetToPageContent w = do
- jsAttrs <- jsAttributesHandler
+    master <- getYesod
- HandlerFor $ \hd -> do
+    hd <- HandlerT return
-  master <- unHandlerFor getYesod hd
+    ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd
-  ref <- newIORef mempty
+    let title = maybe mempty unTitle mTitle
-  unWidgetFor w WidgetData
+        scripts = runUniqueList scripts'
-    { wdRef = ref
+        stylesheets = runUniqueList stylesheets'
-    , wdHandler = hd
-    }
-  GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref
-  let title = maybe mempty unTitle mTitle
-      description = unDescription <$> mDescription
-      scripts = runUniqueList scripts'
-      stylesheets = runUniqueList stylesheets'
 
-  flip unHandlerFor hd $ do
     render <- getUrlRenderParams
     let renderLoc x =
             case x of
@@ -593,7 +586,7 @@ widgetToPageContent w = do
                 ^{mkScriptTag s}
             $maybe j <- jscript
                 $maybe s <- jsLoc
-                    <script src="#{s}" *{jsAttrs}>
+                    <script src="#{s}" *{jsAttributes master}>
                 $nothing
                     <script>^{jelper j}
         |]
@@ -627,7 +620,7 @@ widgetToPageContent w = do
             ^{regularScriptLoad}
         |]
 
-    return $ PageContent title description headAll $
+    return $ PageContent title headAll $
         case jsLoader master of
             BottomOfBody -> bodyScript
             _ -> body
@@ -649,14 +642,13 @@ widgetToPageContent w = do
     runUniqueList (UniqueList x) = nub $ x []
 
 -- | The default error handler for 'errorHandler'.
-defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent
+defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent
 defaultErrorHandler NotFound = selectRep $ do
     provideRep $ defaultLayout $ do
         r <- waiRequest
         let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
         defaultMessageWidget "Not Found" [hamlet|<p>#{path'}|]
     provideRep $ return $ object ["message" .= ("Not Found" :: Text)]
-    provideRep $ return ("Not Found" :: Text)
 
 -- For API requests.
 -- For a user with a browser,
@@ -680,7 +672,6 @@ defaultErrorHandler NotAuthenticated = selectRep $ do
         let apair u = ["authentication_url" .= rend u]
             content = maybe [] apair (authRoute site)
         return $ object $ ("message" .= ("Not logged in"::Text)):content
-    provideRep $ return ("Not logged in" :: Text)
 
 defaultErrorHandler (PermissionDenied msg) = selectRep $ do
     provideRep $ defaultLayout $ defaultMessageWidget
@@ -688,7 +679,6 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do
         [hamlet|<p>#{msg}|]
     provideRep $
         return $ object ["message" .= ("Permission Denied. " <> msg)]
-    provideRep $ return $ "Permission Denied. " <> msg
 
 defaultErrorHandler (InvalidArgs ia) = selectRep $ do
     provideRep $ defaultLayout $ defaultMessageWidget
@@ -699,8 +689,6 @@ defaultErrorHandler (InvalidArgs ia) = selectRep $ do
                     <li>#{msg}
         |]
     provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]
-    provideRep $ return ("Invalid Arguments: " <> T.intercalate " " ia)
-
 defaultErrorHandler (InternalError e) = do
     $logErrorS "yesod-core" e
     selectRep $ do
@@ -708,14 +696,11 @@ defaultErrorHandler (InternalError e) = do
             "Internal Server Error"
             [hamlet|<pre>#{e}|]
         provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]
-        provideRep $ return $ "Internal Server Error: " <> e
-
 defaultErrorHandler (BadMethod m) = selectRep $ do
     provideRep $ defaultLayout $ defaultMessageWidget
         "Method Not Supported"
         [hamlet|<p>Method <code>#{S8.unpack m}</code> not supported|]
     provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
-    provideRep $ return $ "Bad Method " <> TE.decodeUtf8With TEE.lenientDecode m
 
 asyncHelper :: (url -> [x] -> Text)
          -> [Script url]
@@ -863,12 +848,6 @@ clientSessionBackend key getCachedDate =
     sbLoadSession = loadClientSession key getCachedDate "_SESSION"
   }
 
-justSingleton :: a -> [Maybe a] -> a
-justSingleton d = just . catMaybes
-  where
-    just [s] = s
-    just _   = d
-
 loadClientSession :: CS.Key
                   -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
                   -> S8.ByteString -- ^ session name
@@ -879,15 +858,15 @@ loadClientSession key getCachedDate sessionName req = load
     load = do
       date <- getCachedDate
       return (sess date, save date)
-    sess date = justSingleton Map.empty $ do
+    sess date = Map.unions $ do
       raw <- [v | (k, v) <- W.requestHeaders req, k == "Cookie"]
       val <- [v | (k, v) <- parseCookies raw, k == sessionName]
       let host = "" -- fixme, properly lock sessions to client address
-      return $ decodeClientSession key date host val
+      maybe [] return $ decodeClientSession key date host val
     save date sess' = do
       -- We should never cache the IV!  Be careful!
       iv <- liftIO CS.randomIV
-      return [AddCookie defaultSetCookie
+      return [AddCookie def
           { setCookieName = sessionName
           , setCookieValue = encodeClientSession key iv date host sess'
           , setCookiePath = Just "/"

yesod-core/Yesod/Core/Content.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 module Yesod.Core.Content
     ( -- * Content
       Content (..)
@@ -52,24 +53,25 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 import Data.Text.Lazy (Text, pack)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8Builder)
+import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
-import qualified Data.Text.Lazy as TL
+#if __GLASGOW_HASKELL__ < 710
-import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8)
+import Data.Monoid (mempty)
+#endif
 import Text.Hamlet (Html)
 import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
-import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput)
+import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)
 import Control.Monad (liftM)
 import Control.Monad.Trans.Resource (ResourceT)
+import Data.Conduit.Internal (ResumableSource (ResumableSource))
 import qualified Data.Conduit.Internal as CI
 
 import qualified Data.Aeson as J
+import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
 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)
 import Data.Word8 (_semicolon, _slash)
-import Control.Arrow (second)
 
 -- | Zero-length enumerator.
 emptyContent :: Content
@@ -91,27 +93,23 @@ instance ToContent Content where
 instance ToContent Builder where
     toContent = flip ContentBuilder Nothing
 instance ToContent B.ByteString where
-    toContent bs = ContentBuilder (byteString bs) $ Just $ B.length bs
+    toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs
 instance ToContent L.ByteString where
-    toContent = flip ContentBuilder Nothing . lazyByteString
+    toContent = flip ContentBuilder Nothing . fromLazyByteString
 instance ToContent T.Text where
-    toContent = toContent . encodeUtf8Builder
+    toContent = toContent . Blaze.fromText
 instance ToContent Text where
-    toContent = toContent . foldMap encodeUtf8Builder . TL.toChunks
+    toContent = toContent . Blaze.fromLazyText
 instance ToContent String where
-    toContent = toContent . stringUtf8
+    toContent = toContent . Blaze.fromString
 instance ToContent Html where
     toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
 instance ToContent () where
     toContent () = toContent B.empty
-instance ToContent Void where
-    toContent = absurd
 instance ToContent (ContentType, Content) where
     toContent = snd
 instance ToContent TypedContent where
     toContent (TypedContent _ c) = c
-instance ToContent (JSONResponse a) where
-    toContent (JSONResponse a) = toContent $ J.toEncoding a
 
 instance ToContent Css where
     toContent = toContent . renderCss
@@ -119,12 +117,12 @@ instance ToContent Javascript where
     toContent = toContent . toLazyText . unJavascript
 
 instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where
-    toContent src = ContentSource $ CI.ConduitT (CI.mapOutput toFlushBuilder src >>=)
+    toContent src = ContentSource $ CI.ConduitM (CI.mapOutput toFlushBuilder src >>=)
 
-instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where
+instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
     toContent src = ContentSource $ mapOutput toFlushBuilder src
-instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where
+instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where
-    toContent (CI.SealedConduitT src) = toContent src
+    toContent (ResumableSource src _) = toContent src
 
 -- | A class for all data which can be sent in a streaming response. Note that
 -- for textual data, instances must use UTF-8 encoding.
@@ -133,16 +131,16 @@ instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (Resourc
 class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder
 instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id
 instance ToFlushBuilder Builder where toFlushBuilder = Chunk
-instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap byteString
+instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString
-instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . byteString
+instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString
-instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap lazyByteString
+instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap fromLazyByteString
-instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . lazyByteString
+instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . fromLazyByteString
-instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap (foldMap encodeUtf8Builder . TL.toChunks)
+instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap Blaze.fromLazyText
-instance ToFlushBuilder Text where toFlushBuilder = Chunk . foldMap encodeUtf8Builder . TL.toChunks
+instance ToFlushBuilder Text where toFlushBuilder = Chunk . Blaze.fromLazyText
-instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap encodeUtf8Builder
+instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap Blaze.fromText
-instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . encodeUtf8Builder
+instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . Blaze.fromText
-instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap stringUtf8
+instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap Blaze.fromString
-instance ToFlushBuilder String where toFlushBuilder = Chunk . stringUtf8
+instance ToFlushBuilder String where toFlushBuilder = Chunk . Blaze.fromString
 instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder
 instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder
 
@@ -165,8 +163,6 @@ deriving instance ToContent RepJson
 instance HasContentType RepPlain where
     getContentType _ = typePlain
 deriving instance ToContent RepPlain
-instance HasContentType (JSONResponse a) where
-    getContentType _ = typeJson
 
 instance HasContentType RepXml where
     getContentType _ = typeXml
@@ -226,13 +222,13 @@ typeOctet = "application/octet-stream"
 simpleContentType :: ContentType -> ContentType
 simpleContentType = fst . B.break (== _semicolon)
 
--- | Give just the media types as a pair.
+-- Give just the media types as a pair.
---
 -- For example, \"text/html; charset=utf-8\" returns ("text", "html")
 contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString)
-contentTypeTypes = second tailEmpty . B.break (== _slash) . simpleContentType
+contentTypeTypes ct = (main, fst $ B.break (== _semicolon) (tailEmpty sub))
   where
     tailEmpty x = if B.null x then "" else B.tail x
+    (main, sub) = B.break (== _slash) ct
 
 instance HasContentType a => HasContentType (DontFullyEvaluate a) where
     getContentType = getContentType . liftM unDontFullyEvaluate
@@ -279,8 +275,6 @@ instance ToTypedContent TypedContent where
     toTypedContent = id
 instance ToTypedContent () where
     toTypedContent () = TypedContent typePlain (toContent ())
-instance ToTypedContent Void where
-    toTypedContent = absurd
 instance ToTypedContent (ContentType, Content) where
     toTypedContent (ct, content) = TypedContent ct content
 instance ToTypedContent RepJson where
@@ -301,8 +295,6 @@ instance ToTypedContent [Char] where
     toTypedContent = toTypedContent . pack
 instance ToTypedContent Text where
     toTypedContent t = TypedContent typePlain (toContent t)
-instance ToTypedContent (JSONResponse a) where
-    toTypedContent c = TypedContent typeJson (toContent c)
 instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
     toTypedContent (DontFullyEvaluate a) =
         let TypedContent ct c = toTypedContent a

yesod-core/Yesod/Core/Dispatch.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE CPP #-}
 module Yesod.Core.Dispatch
     ( -- * Quasi-quoted routing
       parseRoutes
@@ -10,24 +11,13 @@ module Yesod.Core.Dispatch
     , parseRoutesFile
     , parseRoutesFileNoCheck
     , mkYesod
-    , mkYesodOpts
     , mkYesodWith
       -- ** More fine-grained
     , mkYesodData
-    , mkYesodDataOpts
     , mkYesodSubData
-    , mkYesodSubDataOpts
     , mkYesodDispatch
-    , mkYesodDispatchOpts
     , mkYesodSubDispatch
-      -- *** Route generation options
-    , RouteOpts
-    , defaultOpts
-    , setEqDerived
-    , setShowDerived
-    , setReadDerived
       -- *** Helpers
-    , defaultGen
     , getGetMaxExpires
       -- ** Path pieces
     , PathPiece (..)
@@ -45,6 +35,7 @@ module Yesod.Core.Dispatch
       -- * WAI subsites
     , WaiSubsite (..)
     , WaiSubsiteWithAuth (..)
+    , subHelper
     ) where
 
 import Prelude hiding (exp)
@@ -57,21 +48,21 @@ import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
 
-import Data.Bits ((.|.), finiteBitSize, shiftL)
 import Data.Text (Text)
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid (mappend)
+#endif
 import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Char8 as S8
-import Data.ByteString.Builder (byteString, toLazyByteString)
+import qualified Blaze.ByteString.Builder
 import Network.HTTP.Types (status301, status307)
 import Yesod.Routes.Parse
 import Yesod.Core.Types
 import Yesod.Core.Class.Yesod
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
-import Text.Read (readMaybe)
+import Safe (readMay)
 import System.Environment (getEnvironment)
-import System.Entropy (getEntropy)
 import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
 import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
 
@@ -87,6 +78,7 @@ import Control.Monad.Logger
 import Control.Monad (when)
 import qualified Paths_yesod_core
 import Data.Version (showVersion)
+import qualified System.Random.MWC as MWC
 
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. This function will provide no middlewares; if you want commonly
@@ -95,31 +87,16 @@ toWaiAppPlain :: YesodDispatch site => site -> IO W.Application
 toWaiAppPlain site = do
     logger <- makeLogger site
     sb <- makeSessionBackend site
+    gen <- MWC.createSystemRandom
     getMaxExpires <- getGetMaxExpires
     return $ toWaiAppYre YesodRunnerEnv
             { yreLogger = logger
             , yreSite = site
             , yreSessionBackend = sb
-            , yreGen = defaultGen
+            , yreGen = gen
             , 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
-
 -- | Pure low level function to construct WAI application. Usefull
 -- when you need not standard way to run your app, or want to embed it
 -- inside another app.
@@ -138,7 +115,7 @@ toWaiAppYre yre req =
     sendRedirect y segments' env sendResponse =
          sendResponse $ W.responseLBS status
                 [ ("Content-Type", "text/plain")
-                , ("Location", BL.toStrict $ toLazyByteString dest')
+                , ("Location", Blaze.ByteString.Builder.toByteString dest')
                 ] "Redirecting"
       where
         -- Ensure that non-GET requests get redirected correctly. See:
@@ -152,7 +129,7 @@ toWaiAppYre yre req =
             if S.null (W.rawQueryString env)
                 then dest
                 else dest `mappend`
-                     byteString (W.rawQueryString env)
+                     Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)
 
 -- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This
 -- set may change with future releases, but currently covers:
@@ -174,12 +151,13 @@ toWaiApp site = do
 toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
 toWaiAppLogger logger site = do
     sb <- makeSessionBackend site
+    gen <- MWC.createSystemRandom
     getMaxExpires <- getGetMaxExpires
     let yre = YesodRunnerEnv
                 { yreLogger = logger
                 , yreSite = site
                 , yreSessionBackend = sb
-                , yreGen = defaultGen
+                , yreGen = gen
                 , yreGetMaxExpires = getMaxExpires
                 }
     messageLoggerSource
@@ -197,16 +175,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.
 --
@@ -274,7 +242,7 @@ warpEnv site = do
     case lookup "PORT" env of
         Nothing -> error "warpEnv: no PORT environment variable found"
         Just portS ->
-            case readMaybe portS of
+            case readMay portS of
                 Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS
                 Just port -> warp port site
 

yesod-core/Yesod/Core/Handler.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                        #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE ConstraintKinds            #-}
 {-# LANGUAGE FlexibleInstances          #-}
@@ -8,8 +9,8 @@
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TemplateHaskell            #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -26,7 +27,6 @@
 module Yesod.Core.Handler
     ( -- * Handler monad
       HandlerT
-    , HandlerFor
       -- ** Read information from handler
     , getYesod
     , getsYesod
@@ -46,7 +46,6 @@ module Yesod.Core.Handler
     , fileName
     , fileContentType
     , fileSource
-    , fileSourceByteString
     , fileMove
       -- *** Convenience functions
     , languages
@@ -91,8 +90,7 @@ module Yesod.Core.Handler
     , permissionDeniedI
     , invalidArgs
     , invalidArgsI
-      -- ** Short-circuit responses
+      -- ** Short-circuit responses.
-      -- $rollbackWarning
     , sendFile
     , sendFilePart
     , sendResponse
@@ -100,7 +98,6 @@ module Yesod.Core.Handler
       -- ** Type specific response with custom status
     , sendStatusJSON
     , sendResponseCreated
-    , sendResponseNoContent
     , sendWaiResponse
     , sendWaiApplication
     , sendRawResponse
@@ -120,7 +117,6 @@ module Yesod.Core.Handler
     , setHeader
     , replaceOrAddHeader
     , setLanguage
-    , addContentDispositionFileName
       -- ** Content caching and expiration
     , cacheSeconds
     , neverExpires
@@ -150,11 +146,6 @@ module Yesod.Core.Handler
     , setMessage
     , setMessageI
     , getMessage
-      -- * Subsites
-    , SubHandlerFor
-    , getSubYesod
-    , getRouteToParent
-    , getSubCurrentRoute
       -- * Helpers for specific content
       -- ** Hamlet
     , hamletToRepHtml
@@ -169,11 +160,8 @@ module Yesod.Core.Handler
     , getMessageRender
       -- * Per-request caching
     , cached
-    , cacheGet
-    , cacheSet
     , cachedBy
-    , cacheByGet
+    , stripHandlerT
-    , cacheBySet
       -- * AJAX CSRF protection
 
       -- $ajaxCSRFOverview
@@ -200,15 +188,18 @@ import           Yesod.Core.Internal.Request   (langKey, mkFileInfoFile,
                                                 mkFileInfoLBS, mkFileInfoSource)
 
 
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative           ((<$>))
+import           Data.Monoid                   (mempty, mappend)
+#endif
 import           Control.Applicative           ((<|>))
-import qualified Data.CaseInsensitive          as CI
 import           Control.Exception             (evaluate, SomeException, throwIO)
-import           Control.Exception             (handle)
+import           Control.Exception.Lifted      (handle)
 
 import           Control.Monad                 (void, liftM, unless)
 import qualified Control.Monad.Trans.Writer    as Writer
 
-import           UnliftIO                      (MonadIO, liftIO, MonadUnliftIO, withRunInIO)
+import           Control.Monad.IO.Class        (MonadIO, liftIO)
 
 import qualified Network.HTTP.Types            as H
 import qualified Network.Wai                   as W
@@ -229,7 +220,7 @@ import qualified Data.ByteString.Lazy          as L
 import qualified Data.Map                      as Map
 import qualified Data.HashMap.Strict           as HM
 
-import           Data.ByteArray                (constEq)
+import           Data.Byteable                 (constEqBytes)
 
 import           Control.Arrow                 ((***))
 import qualified Data.ByteString.Char8         as S8
@@ -237,42 +228,40 @@ import           Data.Monoid                   (Endo (..))
 import           Data.Text                     (Text)
 import qualified Network.Wai.Parse             as NWP
 import           Text.Shakespeare.I18N         (RenderMessage (..))
-import           Web.Cookie                    (SetCookie (..), defaultSetCookie)
+import           Web.Cookie                    (SetCookie (..))
 import           Yesod.Core.Content            (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))
 import           Yesod.Core.Internal.Util      (formatRFC1123)
 import           Text.Blaze.Html               (preEscapedToHtml, toHtml)
 
-import qualified Data.IORef                    as I
+import qualified Data.IORef.Lifted             as I
 import           Data.Maybe                    (listToMaybe, mapMaybe)
 import           Data.Typeable                 (Typeable)
-import           Data.Kind                     (Type)
 import           Web.PathPieces                (PathPiece(..))
 import           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
 import           Yesod.Routes.Class            (Route)
-import           Data.ByteString.Builder (Builder)
+import           Blaze.ByteString.Builder (Builder)
+import           Safe (headMay)
 import           Data.CaseInsensitive (CI, original)
 import qualified Data.Conduit.List as CL
 import           Control.Monad.Trans.Resource  (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)
 import qualified System.PosixCompat.Files as PC
-import           Conduit ((.|), runConduit, sinkLazy)
+import           Control.Monad.Trans.Control (control, MonadBaseControl)
-import           Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void)
+import           Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer, Sink)
 import qualified Yesod.Core.TypeCache as Cache
 import qualified Data.Word8 as W8
 import qualified Data.Foldable as Fold
+import           Data.Default
 import           Control.Monad.Logger (MonadLogger, logWarnS)
 
-type HandlerT site (m :: Type -> Type) = HandlerFor site
-{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
-
 get :: MonadHandler m => m GHState
-get = liftHandler $ HandlerFor $ I.readIORef . handlerState
+get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
 
 put :: MonadHandler m => GHState -> m ()
-put x = liftHandler $ HandlerFor $ flip I.writeIORef x . handlerState
+put x = liftHandlerT $ HandlerT $ flip I.writeIORef x . handlerState
 
 modify :: MonadHandler m => (GHState -> GHState) -> m ()
-modify f = liftHandler $ HandlerFor $ flip I.modifyIORef f . handlerState
+modify f = liftHandlerT $ HandlerT $ flip I.modifyIORef f . handlerState
 
 tell :: MonadHandler m => Endo [Header] -> m ()
 tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
@@ -284,14 +273,14 @@ hcError :: MonadHandler m => ErrorResponse -> m a
 hcError = handlerError . HCError
 
 getRequest :: MonadHandler m => m YesodRequest
-getRequest = liftHandler $ HandlerFor $ return . handlerRequest
+getRequest = liftHandlerT $ HandlerT $ return . handlerRequest
 
 runRequestBody :: MonadHandler m => m RequestBodyContents
 runRequestBody = do
     HandlerData
         { handlerEnv = RunHandlerEnv {..}
         , handlerRequest = req
-        } <- liftHandler $ HandlerFor return
+        } <- liftHandlerT $ HandlerT return
     let len = W.requestBodyLength $ reqWaiRequest req
         upload = rheUpload len
     x <- get
@@ -330,8 +319,8 @@ rbHelper' backend mkFI req =
             | otherwise = a'
     go = decodeUtf8With lenientDecode
 
-askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
+askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m))
-askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv
+askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv
 
 -- | Get the master site application argument.
 getYesod :: MonadHandler m => m (HandlerSite m)
@@ -371,10 +360,10 @@ getPostParams = do
 getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
 getCurrentRoute = rheRoute <$> askHandlerEnv
 
--- | Returns a function that runs 'HandlerFor' actions inside @IO@.
+-- | Returns a function that runs 'HandlerT' actions inside @IO@.
 --
--- Sometimes you want to run an inner 'HandlerFor' action outside
+-- Sometimes you want to run an inner 'HandlerT' action outside
--- the control flow of an HTTP request (on the outer 'HandlerFor'
+-- the control flow of an HTTP request (on the outer 'HandlerT'
 -- action).  For example, you may want to spawn a new thread:
 --
 -- @
@@ -382,34 +371,34 @@ getCurrentRoute = rheRoute <$> askHandlerEnv
 -- getFooR = do
 --   runInnerHandler <- handlerToIO
 --   liftIO $ forkIO $ runInnerHandler $ do
---     /Code here runs inside HandlerFor but on a new thread./
+--     /Code here runs inside GHandler but on a new thread./
---     /This is the inner HandlerFor./
+--     /This is the inner GHandler./
 --     ...
 --   /Code here runs inside the request's control flow./
---   /This is the outer HandlerFor./
+--   /This is the outer GHandler./
 --   ...
 -- @
 --
 -- Another use case for this function is creating a stream of
--- server-sent events using 'HandlerFor' actions (see
+-- server-sent events using 'GHandler' actions (see
 -- @yesod-eventsource@).
 --
--- Most of the environment from the outer 'HandlerFor' is preserved
+-- Most of the environment from the outer 'GHandler' is preserved
--- on the inner 'HandlerFor', however:
+-- on the inner 'GHandler', however:
 --
 --  * The request body is cleared (otherwise it would be very
 --  difficult to prevent huge memory leaks).
 --
---  * The cache is cleared (see 'cached').
+--  * The cache is cleared (see 'CacheKey').
 --
--- Changes to the response made inside the inner 'HandlerFor' are
+-- Changes to the response made inside the inner 'GHandler' are
 -- ignored (e.g., session variables, cookies, response headers).
--- This allows the inner 'HandlerFor' to outlive the outer
+-- This allows the inner 'GHandler' to outlive the outer
--- 'HandlerFor' (e.g., on the @forkIO@ example above, a response
+-- 'GHandler' (e.g., on the @forkIO@ example above, a response
 -- may be sent to the client without killing the new thread).
-handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a)
+handlerToIO :: (MonadIO m1, MonadIO m2) => HandlerT site m1 (HandlerT site IO a -> m2 a)
 handlerToIO =
-  HandlerFor $ \oldHandlerData -> do
+  HandlerT $ \oldHandlerData -> do
     -- Take just the bits we need from oldHandlerData.
     let newReq = oldReq { reqWaiRequest = newWaiReq }
           where
@@ -430,8 +419,8 @@ 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) ->
+    return $ \(HandlerT f) ->
       liftIO $
       runResourceT $ withInternalState $ \resState -> do
         -- The state IORef needs to be created here, otherwise it
@@ -442,6 +431,7 @@ handlerToIO =
                 { handlerRequest  = newReq
                 , handlerEnv      = oldEnv
                 , handlerState    = newStateIORef
+                , handlerToParent = const ()
                 , handlerResource = resState
                 }
         liftIO (f newHandlerData)
@@ -452,13 +442,12 @@ handlerToIO =
 -- for correctness and efficiency
 --
 -- @since 1.2.8
-forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler
+forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler
-              -> HandlerFor site ()
+              -> HandlerT site IO ()
-              -> HandlerFor site ()
+              -> HandlerT site IO ()
 forkHandler onErr handler = do
     yesRunner <- handlerToIO
-    void $ liftResourceT $ resourceForkIO $
+    void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler
-      liftIO $ handle (yesRunner . onErr) (yesRunner handler)
 
 -- | Redirect to the given route.
 -- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
@@ -607,21 +596,7 @@ setMessageI = addMessageI ""
 -- | Gets just the last message in the user's session,
 -- discards the rest and the status
 getMessage :: MonadHandler m => m (Maybe Html)
-getMessage = fmap (fmap snd . listToMaybe) getMessages
+getMessage = fmap (fmap snd . headMay) getMessages
-
--- $rollbackWarning
---
--- Note that since short-circuiting is implemented by using exceptions,
--- using e.g. 'sendStatusJSON' inside a runDB block
--- will result in the database actions getting rolled back:
---
--- @
--- runDB $ do
---   userId <- insert $ User "username" "email@example.com"
---   postId <- insert $ BlogPost "title" "hi there!"
---     /The previous two inserts will be rolled back./
---   sendStatusJSON Status.status200 ()
--- @
 
 -- | Bypass remaining handler code and output the given file.
 --
@@ -669,12 +644,6 @@ sendResponseCreated url = do
     r <- getUrlRender
     handlerError $ HCCreated $ r url
 
--- | Bypass remaining handler code and output no content with a 204 status code.
---
--- @since 1.6.9
-sendResponseNoContent :: MonadHandler m => m a
-sendResponseNoContent = sendWaiResponse $ W.responseBuilder H.status204 [] mempty
-
 -- | Send a 'W.Response'. Please note: this function is rarely
 -- necessary, and will /disregard/ any changes to response headers and session
 -- that you have already specified. This function short-circuits. It should be
@@ -695,10 +664,10 @@ sendWaiApplication = handlerError . HCWaiApp
 --
 -- @since 1.2.16
 sendRawResponseNoConduit
-    :: (MonadHandler m, MonadUnliftIO m)
+    :: (MonadHandler m, MonadBaseControl IO m)
     => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
     -> m a
-sendRawResponseNoConduit raw = withRunInIO $ \runInIO ->
+sendRawResponseNoConduit raw = control $ \runInIO ->
     liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
     $ \src sink -> void $ runInIO (raw src sink)
   where
@@ -710,11 +679,10 @@ sendRawResponseNoConduit raw = withRunInIO $ \runInIO ->
 -- Warp).
 --
 -- @since 1.2.7
-sendRawResponse
+sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
-  :: (MonadHandler m, MonadUnliftIO m)
+                => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())
-  => (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ())
+                -> m a
-  -> m a
+sendRawResponse raw = control $ \runInIO ->
-sendRawResponse raw = withRunInIO $ \runInIO ->
     liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
     $ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink)
   where
@@ -804,26 +772,6 @@ deleteCookie a = addHeaderInternal . DeleteCookie (encodeUtf8 a) . encodeUtf8
 setLanguage :: MonadHandler m => Text -> m ()
 setLanguage = setSession langKey
 
--- | Set attachment file name.
---
--- Allows Unicode characters by encoding to UTF-8.
--- Some modurn browser parse UTF-8 characters with out encoding setting.
--- But, for example IE9 can't parse UTF-8 characters.
--- This function use
--- <https://tools.ietf.org/html/rfc6266 RFC 6266>(<https://tools.ietf.org/html/rfc5987 RFC 5987>)
---
--- @since 1.6.4
-addContentDispositionFileName :: MonadHandler m => T.Text -> m ()
-addContentDispositionFileName fileName
-    = addHeader "Content-Disposition" $ rfc6266Utf8FileName fileName
-
--- | <https://tools.ietf.org/html/rfc6266 RFC 6266> Unicode attachment filename.
---
--- > rfc6266Utf8FileName (Data.Text.pack "€")
--- "attachment; filename*=UTF-8''%E2%82%AC"
-rfc6266Utf8FileName :: T.Text -> T.Text
-rfc6266Utf8FileName fileName = "attachment; filename*=UTF-8''" `mappend` decodeUtf8 (H.urlEncode True (encodeUtf8 fileName))
-
 -- | Set an arbitrary response header.
 --
 -- Note that, while the data type used here is 'Text', you must provide only
@@ -831,7 +779,7 @@ rfc6266Utf8FileName fileName = "attachment; filename*=UTF-8''" `mappend` decodeU
 --
 -- @since 1.2.0
 addHeader :: MonadHandler m => Text -> Text -> m ()
-addHeader a = addHeaderInternal . Header (CI.mk $ encodeUtf8 a) . encodeUtf8
+addHeader a = addHeaderInternal . Header (encodeUtf8 a) . encodeUtf8
 
 -- | Deprecated synonym for addHeader.
 setHeader :: MonadHandler m => Text -> Text -> m ()
@@ -849,10 +797,10 @@ replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()
 replaceOrAddHeader a b =
   modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)}
   where
-    repHeader = Header (CI.mk $ encodeUtf8 a) (encodeUtf8 b)
+    repHeader = Header (encodeUtf8 a) (encodeUtf8 b)
 
     sameHeaderName :: Header -> Header -> Bool
-    sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2
+    sameHeaderName (Header n1 _) (Header n2 _) = T.toLower (decodeUtf8 n1) == T.toLower (decodeUtf8 n2)
     sameHeaderName _ _ = False
 
     replaceIndividualHeader :: [Header] -> [Header]
@@ -1038,7 +986,7 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map k
 -- > redirect (NewsfeedR :#: storyId)
 --
 -- @since 1.2.9.
-data Fragment a b = a :#: b deriving Show
+data Fragment a b = a :#: b deriving (Show, Typeable)
 
 instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where
   toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a
@@ -1085,15 +1033,13 @@ $doctype 5
 <html>
     <head>
         <title>Redirecting...
-    <body>
+    <body onload="document.getElementById('form').submit()">
         <form id="form" method="post" action=#{urlText}>
             $maybe token <- reqToken req
                 <input type=hidden name=#{defaultCsrfParamName} value=#{token}>
             <noscript>
                 <p>Javascript has been disabled; please click on the button below to be redirected.
             <input type="submit" value="Continue">
-        <script>
-          window.onload = function() { document.getElementById('form').submit(); };
 |] >>= sendResponse
 
 -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
@@ -1156,27 +1102,6 @@ cached action = do
           put $ gs { ghsCache = merged }
           return res
 
--- | Retrieves a value from the cache used by 'cached'.
---
--- @since 1.6.10
-cacheGet :: (MonadHandler m, Typeable a)
-         => m (Maybe a)
-cacheGet = do
-  cache <- ghsCache <$> get
-  pure $ Cache.cacheGet cache
-
--- | Sets a value in the cache used by 'cached'.
---
--- @since 1.6.10
-cacheSet :: (MonadHandler m, Typeable a)
-         => a
-         -> m ()
-cacheSet value = do
-  gs <- get
-  let cache = ghsCache gs
-      newCache = Cache.cacheSet value cache
-  put $ gs { ghsCache = newCache }
-
 -- | a per-request cache. just like 'cached'.
 -- 'cached' can only cache a single value per type.
 -- 'cachedBy' stores multiple values per type by usage of a ByteString key
@@ -1199,38 +1124,15 @@ cachedBy k action = do
           put $ gs { ghsCacheBy = merged }
           return res
 
--- | Retrieves a value from the cache used by 'cachedBy'.
---
--- @since 1.6.10
-cacheByGet :: (MonadHandler m, Typeable a)
-           => S.ByteString
-           -> m (Maybe a)
-cacheByGet key = do
-  cache <- ghsCacheBy <$> get
-  pure $ Cache.cacheByGet key cache
-
--- | Sets a value in the cache used by 'cachedBy'.
---
--- @since 1.6.10
-cacheBySet :: (MonadHandler m, Typeable a)
-           => S.ByteString
-           -> a
-           -> m ()
-cacheBySet key value = do
-  gs <- get
-  let cache = ghsCacheBy gs
-      newCache = Cache.cacheBySet key value cache
-  put $ gs { ghsCacheBy = newCache }
-
 -- | Get the list of supported languages supplied by the user.
 --
 -- Languages are determined based on the following (in descending order
 -- of preference):
 --
--- * The _LANG get parameter.
---
 -- * The _LANG user session variable.
 --
+-- * The _LANG get parameter.
+--
 -- * The _LANG cookie.
 --
 -- * Accept-Language HTTP header.
@@ -1239,12 +1141,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)
@@ -1363,9 +1264,15 @@ selectRep w = do
         [] ->
             case reps of
                 [] -> sendResponseStatus H.status500 ("No reps provided to selectRep" :: Text)
-                rep:_ -> returnRep rep
+                rep:_ ->
+                  if null cts
+                    then returnRep rep
+                    else sendResponseStatus H.status406 explainUnaccepted
         rep:_ -> returnRep rep
   where
+    explainUnaccepted :: Text
+    explainUnaccepted = "no match found for accept header"
+
     returnRep (ProvidedRep ct mcontent) = fmap (TypedContent ct) mcontent
 
     reps = appEndo (Writer.execWriter w) []
@@ -1384,7 +1291,7 @@ selectRep w = do
     tryAccept ct =
         if subType == "*"
           then if mainType == "*"
-                 then listToMaybe reps
+                 then headMay reps
                  else Map.lookup mainType mainTypeMap
           else lookupAccept ct
         where
@@ -1430,7 +1337,7 @@ provideRepType ct handler =
 -- | Stream in the raw request body without any parsing.
 --
 -- @since 1.2.0
-rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m ()
+rawRequestBody :: MonadHandler m => Source m S.ByteString
 rawRequestBody = do
     req <- lift waiRequest
     let loop = do
@@ -1442,20 +1349,9 @@ rawRequestBody = do
 
 -- | Stream the data from the file. Since Yesod 1.2, this has been generalized
 -- to work in any @MonadResource@.
-fileSource :: MonadResource m => FileInfo -> ConduitT () S.ByteString m ()
+fileSource :: MonadResource m => FileInfo -> Source m S.ByteString
 fileSource = transPipe liftResourceT . fileSourceRaw
 
--- | Extract a strict `ByteString` body from a `FileInfo`.
---
--- This function will block while reading the file.
---
--- > do
--- >     fileByteString <- fileSourceByteString fileInfo
---
--- @since 1.6.5
-fileSourceByteString :: MonadResource m => FileInfo -> m S.ByteString
-fileSourceByteString fileInfo = runConduit (L.toStrict <$> (fileSource fileInfo .| sinkLazy))
-
 -- | Provide a pure value for the response body.
 --
 -- > respond ct = return . TypedContent ct . toContent
@@ -1466,67 +1362,86 @@ respond ct = return . TypedContent ct . toContent
 
 -- | Use a @Source@ for the response body.
 --
--- Note that, for ease of use, the underlying monad is a @HandlerFor@. This
+-- Note that, for ease of use, the underlying monad is a @HandlerT@. This
--- implies that you can run any @HandlerFor@ action. However, since a streaming
+-- implies that you can run any @HandlerT@ action. However, since a streaming
 -- response occurs after the response headers have already been sent, some
 -- actions make no sense here. For example: short-circuit responses, setting
 -- headers, changing status codes, etc.
 --
 -- @since 1.2.0
 respondSource :: ContentType
-              -> ConduitT () (Flush Builder) (HandlerFor site) ()
+              -> Source (HandlerT site IO) (Flush Builder)
-              -> HandlerFor site TypedContent
+              -> HandlerT site IO TypedContent
-respondSource ctype src = HandlerFor $ \hd ->
+respondSource ctype src = HandlerT $ \hd ->
     -- Note that this implementation relies on the fact that the ResourceT
-    -- environment provided by the server is the same one used in HandlerFor.
+    -- environment provided by the server is the same one used in HandlerT.
-    -- This is a safe assumption assuming the HandlerFor is run correctly.
+    -- This is a safe assumption assuming the HandlerT is run correctly.
     return $ TypedContent ctype $ ContentSource
-           $ transPipe (lift . flip unHandlerFor hd) src
+           $ transPipe (lift . flip unHandlerT hd) src
 
 -- | In a streaming response, send a single chunk of data. This function works
 -- on most datatypes, such as @ByteString@ and @Html@.
 --
 -- @since 1.2.0
-sendChunk :: Monad m => ToFlushBuilder a => a -> ConduitT i (Flush Builder) m ()
+sendChunk :: Monad m => ToFlushBuilder a => a -> Producer m (Flush Builder)
 sendChunk = yield . toFlushBuilder
 
 -- | In a streaming response, send a flush command, causing all buffered data
 -- to be immediately sent to the client.
 --
 -- @since 1.2.0
-sendFlush :: Monad m => ConduitT i (Flush Builder) m ()
+sendFlush :: Monad m => Producer m (Flush Builder)
 sendFlush = yield Flush
 
 -- | Type-specialized version of 'sendChunk' for strict @ByteString@s.
 --
 -- @since 1.2.0
-sendChunkBS :: Monad m => S.ByteString -> ConduitT i (Flush Builder) m ()
+sendChunkBS :: Monad m => S.ByteString -> Producer m (Flush Builder)
 sendChunkBS = sendChunk
 
 -- | Type-specialized version of 'sendChunk' for lazy @ByteString@s.
 --
 -- @since 1.2.0
-sendChunkLBS :: Monad m => L.ByteString -> ConduitT i (Flush Builder) m ()
+sendChunkLBS :: Monad m => L.ByteString -> Producer m (Flush Builder)
 sendChunkLBS = sendChunk
 
 -- | Type-specialized version of 'sendChunk' for strict @Text@s.
 --
 -- @since 1.2.0
-sendChunkText :: Monad m => T.Text -> ConduitT i (Flush Builder) m ()
+sendChunkText :: Monad m => T.Text -> Producer m (Flush Builder)
 sendChunkText = sendChunk
 
 -- | Type-specialized version of 'sendChunk' for lazy @Text@s.
 --
 -- @since 1.2.0
-sendChunkLazyText :: Monad m => TL.Text -> ConduitT i (Flush Builder) m ()
+sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder)
 sendChunkLazyText = sendChunk
 
 -- | Type-specialized version of 'sendChunk' for @Html@s.
 --
 -- @since 1.2.0
-sendChunkHtml :: Monad m => Html -> ConduitT i (Flush Builder) m ()
+sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)
 sendChunkHtml = sendChunk
 
+-- | Converts a child handler to a parent handler
+--
+-- Exported since 1.4.11
+stripHandlerT :: HandlerT child (HandlerT parent m) a
+              -> (parent -> child)
+              -> (Route child -> Route parent)
+              -> Maybe (Route child)
+              -> HandlerT parent m a
+stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do
+    let env = handlerEnv hd
+    ($ hd) $ unHandlerT $ f hd
+        { handlerEnv = env
+            { rheSite = getSub $ rheSite env
+            , rheRoute = newRoute
+            , rheRender = \url params -> rheRender env (toMaster url) params
+            }
+        , handlerToParent = toMaster
+        }
+
 -- $ajaxCSRFOverview
 -- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in.
 -- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs.
@@ -1545,23 +1460,6 @@ sendChunkHtml = sendChunk
 -- The form-based approach has the advantage of working for users with Javascript disabled, while adding the token to the headers with Javascript allows things like submitting JSON or binary data in AJAX requests. Yesod supports checking for a CSRF token in either the POST parameters of the form ('checkCsrfParamNamed'), the headers ('checkCsrfHeaderNamed'), or both options ('checkCsrfHeaderOrParam').
 --
 -- The easiest way to check both sources is to add the 'Yesod.Core.defaultCsrfMiddleware' to your Yesod Middleware.
---
--- === Opting-out of CSRF checking for specific routes
---
--- (Note: this code is generic to opting out of any Yesod middleware)
---
--- @
--- 'yesodMiddleware' app = do
---   maybeRoute <- 'getCurrentRoute'
---   let dontCheckCsrf = case maybeRoute of
---                         Just HomeR                     -> True  -- Don't check HomeR
---                         Nothing                        -> True  -- Don't check for 404s
---                         _                              -> False -- Check other routes
---
---   'defaultYesodMiddleware' $ 'defaultCsrfSetCookieMiddleware' $ (if dontCheckCsrf then 'id' else 'defaultCsrfCheckMiddleware') $ app
--- @
---
--- This can also be implemented using the 'csrfCheckMiddleware' function.
 
 -- | The default cookie name for the CSRF token ("XSRF-TOKEN").
 --
@@ -1575,10 +1473,7 @@ defaultCsrfCookieName = "XSRF-TOKEN"
 --
 -- @since 1.4.14
 setCsrfCookie :: MonadHandler m => m ()
-setCsrfCookie = setCsrfCookieWithCookie defaultSetCookie
+setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieName, setCookiePath = Just "/" }
-  { setCookieName = defaultCsrfCookieName
-  , setCookiePath = Just "/"
-  }
 
 -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie.
 --
@@ -1667,8 +1562,8 @@ checkCsrfHeaderOrParam headerName paramName = do
     permissionDenied errorMessage
 
 validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool
--- It's important to use constant-time comparison (constEq) in order to avoid timing attacks.
+-- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.
-validCsrf (Just token) (Just param) = encodeUtf8 token `constEq` param
+validCsrf (Just token) (Just param) = encodeUtf8 token `constEqBytes` param
 validCsrf Nothing            _param = True
 validCsrf (Just _token)     Nothing = False
 
@@ -1694,12 +1589,3 @@ csrfErrorMessage expectedLocations = T.intercalate "\n"
         formatValue maybeText = case maybeText of
           Nothing -> "(which is not currently set)"
           Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"]
-
-getSubYesod :: MonadHandler m => m (SubHandlerSite m)
-getSubYesod = liftSubHandler $ SubHandlerFor $ return . rheChild . handlerEnv
-
-getRouteToParent :: MonadHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m))
-getRouteToParent = liftSubHandler $ SubHandlerFor $ return . rheRouteToMaster . handlerEnv
-
-getSubCurrentRoute :: MonadHandler m => m (Maybe (Route (SubHandlerSite m)))
-getSubCurrentRoute = liftSubHandler $ SubHandlerFor $ return . rheRoute . handlerEnv

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

@@ -1,8 +1,8 @@
 {-# LANGUAGE TypeFamilies, PatternGuards, CPP #-}
 module Yesod.Core.Internal.LiteApp where
 
-#if !(MIN_VERSION_base(4,11,0))
+#if __GLASGOW_HASKELL__ < 710
-import Data.Semigroup (Semigroup(..))
+import Data.Monoid
 #endif
 import Yesod.Routes.Class
 import Yesod.Core.Class.Yesod
@@ -42,17 +42,12 @@ instance RenderRoute LiteApp where
 instance ParseRoute LiteApp where
     parseRoute (x, _) = Just $ LiteAppRoute x
 
-instance Semigroup LiteApp where
-    LiteApp x <> LiteApp y = LiteApp $ \m ps -> x m ps <|> y m ps
-
 instance Monoid LiteApp where
     mempty = LiteApp $ \_ _ -> Nothing
-#if !(MIN_VERSION_base(4,11,0))
+    mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps
-    mappend = (<>)
-#endif
 
-type LiteHandler = HandlerFor LiteApp
+type LiteHandler = HandlerT LiteApp IO
-type LiteWidget = WidgetFor LiteApp
+type LiteWidget = WidgetT LiteApp IO
 
 liteApp :: Writer LiteApp () -> LiteApp
 liteApp = execWriter

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

@@ -25,7 +25,6 @@ import qualified Network.Wai as W
 import Web.Cookie (parseCookiesText)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as S8
-import qualified Data.ByteString.Lazy.Char8 as LS8
 import Data.Text (Text, pack)
 import Network.HTTP.Types (queryToQueryText, Status (Status))
 import Data.Maybe (fromMaybe, catMaybes)
@@ -34,13 +33,18 @@ import qualified Data.Set as Set
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With, decodeUtf8)
 import Data.Text.Encoding.Error (lenientDecode)
-import Conduit
+import Data.Conduit
+import Data.Conduit.List (sourceList)
+import Data.Conduit.Binary (sourceFile, sinkFile)
 import Data.Word (Word8, Word64)
+import Control.Monad.Trans.Resource (runResourceT, ResourceT)
 import Control.Exception (throwIO)
 import Control.Monad ((<=<), liftM)
 import Yesod.Core.Types
 import qualified Data.Map as Map
 import Data.IORef
+import qualified System.Random.MWC as MWC
+import Control.Monad.Primitive (PrimMonad, PrimState)
 import qualified Data.Vector.Storable as V
 import Data.ByteString.Internal (ByteString (PS))
 import qualified Data.Word8 as Word8
@@ -56,29 +60,23 @@ limitRequestBody maxLen req = do
             let len = fromIntegral $ S8.length bs
                 remaining' = remaining - len
             if remaining < len
-                then throwIO $ HCWai $ tooLargeResponse maxLen len
+                then throwIO $ HCWai tooLargeResponse
                 else do
                     writeIORef ref remaining'
                     return bs
         }
 
-tooLargeResponse :: Word64 -> Word64 -> W.Response
+tooLargeResponse :: W.Response
-tooLargeResponse maxLen bodyLen = W.responseLBS
+tooLargeResponse = W.responseLBS
     (Status 413 "Too Large")
     [("Content-Type", "text/plain")]
-    (L.concat 
+    "Request body too large to be processed."
-        [ "Request body too large to be processed. The maximum size is "
-        , (LS8.pack (show maxLen))
-        , " bytes; your request body was "
-        , (LS8.pack (show bodyLen))
-        , " bytes. If you're the developer of this site, you can configure the maximum length with the `maximumContentLength` or `maximumContentLengthIO` function on the Yesod typeclass."
-        ])
 
 parseWaiRequest :: W.Request
                 -> SessionMap
                 -> Bool
                 -> Maybe Word64 -- ^ max body size
-                -> Either (IO YesodRequest) (IO Int -> IO YesodRequest)
+                -> Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest)
 parseWaiRequest env session useToken mmaxBodySize =
     -- In most cases, we won't need to generate any random values. Therefore,
     -- we split our results: if we need a random generator, return a Right
@@ -129,7 +127,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)]
@@ -158,21 +156,16 @@ addTwoLetters (toAdd, exist) (l:ls) =
 -- | Generate a random String of alphanumerical characters
 -- (a-z, A-Z, and 0-9) of the given length using the given
 -- random number generator.
-randomString :: Monad m => Int -> m Int -> m Text
+randomString :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m Text
 randomString len gen =
     liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar
   where
-    asciiChar =
+    asciiChar = liftM toAscii $ MWC.uniformR (0, 61) gen
-      let loop = do
+
-            x <- gen
+    toAscii i
-            let y = fromIntegral $ x `mod` 64
+        | i < 26 = i + Word8._A
-            case () of
+        | i < 52 = i + Word8._a - 26
-              ()
+        | otherwise = i + Word8._0 - 52
-                | y < 26 -> return $ y + Word8._A
-                | y < 52 -> return $ y + Word8._a - 26
-                | y < 62 -> return $ y + Word8._0 - 52
-                | otherwise -> loop
-       in loop
 
 fromByteVector :: V.Vector Word8 -> ByteString
 fromByteVector v =
@@ -183,13 +176,13 @@ fromByteVector v =
 
 mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
 mkFileInfoLBS name ct lbs =
-    FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs)
+    FileInfo name ct (sourceList $ L.toChunks lbs) (`L.writeFile` lbs)
 
 mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo
-mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runConduitRes $ sourceFile fp .| sinkFile dst)
+mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)
 
-mkFileInfoSource :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo
+mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo
-mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst)
+mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)
 
 tokenKey :: IsString a => a
 tokenKey = "_TOKEN"

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

@@ -6,8 +6,8 @@ module Yesod.Core.Internal.Response where
 import           Data.ByteString              (ByteString)
 import qualified Data.ByteString              as S
 import qualified Data.ByteString.Char8        as S8
-import qualified Data.ByteString.Lazy         as BL
 import           Data.CaseInsensitive         (CI)
+import qualified Data.CaseInsensitive         as CI
 import           Network.Wai
 import           Control.Monad                (mplus)
 import           Control.Monad.Trans.Resource (runInternalState, InternalState)
@@ -18,12 +18,14 @@ import           Yesod.Core.Types
 import qualified Network.HTTP.Types           as H
 import qualified Data.Text                    as T
 import           Control.Exception            (SomeException, handle)
-import           Data.ByteString.Builder      (lazyByteString, toLazyByteString)
+import           Blaze.ByteString.Builder     (fromLazyByteString,
+                                               toLazyByteString, toByteString)
 import qualified Data.ByteString.Lazy         as L
 import qualified Data.Map                     as Map
 import           Yesod.Core.Internal.Request  (tokenKey)
 import           Data.Text.Encoding           (encodeUtf8)
-import           Conduit
+import           Data.Conduit                 (Flush (..), ($$), transPipe)
+import qualified Data.Conduit.List            as CL
 
 yarToResponse :: YesodResponse
               -> (SessionMap -> IO [Header]) -- ^ save session
@@ -51,9 +53,9 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse
             sendResponse $ ResponseBuilder s hs' b
         go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p
         go (ContentSource body) = sendResponse $ responseStream s finalHeaders
-            $ \sendChunk flush -> runConduit $
+            $ \sendChunk flush ->
                 transPipe (`runInternalState` is) body
-                .| mapM_C (\mchunk ->
+                $$ CL.mapM_ (\mchunk ->
                     case mchunk of
                         Flush -> flush
                         Chunk builder -> sendChunk builder)
@@ -81,7 +83,7 @@ defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"
 headerToPair :: Header
              -> (CI ByteString, ByteString)
 headerToPair (AddCookie sc) =
-    ("Set-Cookie", BL.toStrict $ toLazyByteString $ renderSetCookie sc)
+    ("Set-Cookie", toByteString $ renderSetCookie sc)
 headerToPair (DeleteCookie key path) =
     ( "Set-Cookie"
     , S.concat
@@ -91,14 +93,14 @@ headerToPair (DeleteCookie key path) =
         , "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
         ]
     )
-headerToPair (Header key value) = (key, value)
+headerToPair (Header key value) = (CI.mk key, value)
 
 evaluateContent :: Content -> IO (Either ErrorResponse Content)
 evaluateContent (ContentBuilder b mlen) = handle f $ do
     let lbs = toLazyByteString b
         len = L.length lbs
         mlen' = mlen `mplus` Just (fromIntegral len)
-    len `seq` return (Right $ ContentBuilder (lazyByteString lbs) mlen')
+    len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')
   where
     f :: SomeException -> IO (Either ErrorResponse Content)
     f = return . Left . InternalError . T.pack . show

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

@@ -1,31 +1,22 @@
-{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE CPP               #-}
-{-# LANGUAGE PatternGuards       #-}
+{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE PatternGuards     #-}
-{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE TupleSections     #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts  #-}
-module Yesod.Core.Internal.Run
+module Yesod.Core.Internal.Run where
-  ( toErrorHandler
-  , errFromShow
-  , basicRunHandler
-  , handleError
-  , handleContents
-  , evalFallback
-  , runHandler
-  , safeEh
-  , runFakeHandler
-  , yesodRunner
-  , yesodRender
-  , resolveApproot
-  )
-  where
 
-import qualified Control.Exception as EUnsafe
+
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Monoid                  (Monoid, mempty)
+import           Control.Applicative          ((<$>))
+#endif
 import Yesod.Core.Internal.Response
-import           Data.ByteString.Builder      (toLazyByteString)
+import           Blaze.ByteString.Builder     (toByteString)
-import qualified Data.ByteString.Lazy         as BL
+import           Control.Exception            (fromException, evaluate)
+import qualified Control.Exception            as E
 import           Control.Monad.IO.Class       (MonadIO, liftIO)
 import           Control.Monad.Logger         (LogLevel (LevelError), LogSource,
                                                liftLoc)
@@ -53,31 +44,46 @@ import           Yesod.Core.Internal.Request  (parseWaiRequest,
 import           Yesod.Core.Internal.Util     (getCurrentMaxExpiresRFC1123)
 import           Yesod.Routes.Class           (Route, renderRoute)
 import           Control.DeepSeq              (($!!), NFData)
-import           UnliftIO.Exception
-import           UnliftIO(MonadUnliftIO, withRunInIO)
-import           Data.Proxy(Proxy(..))
 
--- | Convert a synchronous exception into an ErrorResponse
+-- | Catch all synchronous exceptions, ignoring asynchronous
-toErrorHandler :: SomeException -> IO ErrorResponse
+-- exceptions.
-toErrorHandler e0 = handleAny errFromShow $
+--
+-- Ideally we'd use this from a different library
+catchSync :: IO a -> (E.SomeException -> IO a) -> IO a
+catchSync thing after = thing `E.catch` \e ->
+    if isAsyncException e
+        then E.throwIO e
+        else after e
+
+-- | Determine if an exception is asynchronous
+--
+-- Also worth being upstream
+isAsyncException :: E.SomeException -> Bool
+isAsyncException e =
+    case fromException e of
+        Just E.SomeAsyncException{} -> True
+        Nothing -> False
+
+-- | Convert an exception into an ErrorResponse
+toErrorHandler :: E.SomeException -> IO ErrorResponse
+toErrorHandler e0 = flip catchSync errFromShow $
     case fromException e0 of
         Just (HCError x) -> evaluate $!! x
-        _ -> errFromShow e0
+        _
+            | isAsyncException e0 -> E.throwIO e0
+            | otherwise -> errFromShow e0
 
 -- | Generate an @ErrorResponse@ based on the shown version of the exception
-errFromShow :: SomeException -> IO ErrorResponse
+errFromShow :: E.SomeException -> IO ErrorResponse
-errFromShow x = do
+errFromShow x = evaluate $!! InternalError $! T.pack $! show x
-  text <- evaluate (T.pack $ show x) `catchAny` \_ ->
-          return (T.pack "Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception")
-  return $ InternalError text
 
 -- | Do a basic run of a handler, getting some contents and the final
 -- @GHState@. The @GHState@ unfortunately may contain some impure
 -- exceptions, but all other synchronous exceptions will be caught and
 -- represented by the @HandlerContents@.
 basicRunHandler :: ToTypedContent c
-                => RunHandlerEnv site site
+                => RunHandlerEnv site
-                -> HandlerFor site c
+                -> HandlerT site IO c
                 -> YesodRequest
                 -> InternalState
                 -> IO (GHState, HandlerContents)
@@ -88,9 +94,9 @@ basicRunHandler rhe handler yreq resState = do
 
     -- Run the handler itself, capturing any runtime exceptions and
     -- converting them into a @HandlerContents@
-    contents' <- rheCatchHandlerExceptions rhe
+    contents' <- catchSync
         (do
-            res <- unHandlerFor handler (hd istate)
+            res <- unHandlerT handler (hd istate)
             tc <- evaluate (toTypedContent res)
             -- Success! Wrap it up in an @HCContent@
             return (HCContent defaultStatus tc))
@@ -115,11 +121,12 @@ basicRunHandler rhe handler yreq resState = do
         { handlerRequest = yreq
         , handlerEnv     = rhe
         , handlerState   = istate
+        , handlerToParent = const ()
         , handlerResource = resState
         }
 
 -- | Convert an @ErrorResponse@ into a @YesodResponse@
-handleError :: RunHandlerEnv sub site
+handleError :: RunHandlerEnv site
             -> YesodRequest
             -> InternalState
             -> Map.Map Text S8.ByteString
@@ -128,7 +135,7 @@ handleError :: RunHandlerEnv sub site
             -> IO YesodResponse
 handleError rhe yreq resState finalSession headers e0 = do
     -- Find any evil hidden impure exceptions
-    e <- (evaluate $!! e0) `catchAny` errFromShow
+    e <- (evaluate $!! e0) `catchSync` errFromShow
 
     -- Generate a response, leveraging the updated session and
     -- response headers
@@ -189,22 +196,19 @@ handleContents handleError' finalSession headers contents =
 -- | Evaluate the given value. If an exception is thrown, use it to
 -- replace the provided contents and then return @mempty@ in place of the
 -- evaluated value.
---
--- Note that this also catches async exceptions.
 evalFallback :: (Monoid w, NFData w)
-             => (forall a. IO a -> (SomeException -> IO a) -> IO a)
+             => HandlerContents
-             -> HandlerContents
              -> w
              -> IO (w, HandlerContents)
-evalFallback catcher contents val = catcher
+evalFallback contents val = catchSync
     (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
+           => RunHandlerEnv site
-           -> HandlerFor site c
+           -> HandlerT site IO c
            -> YesodApp
 runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
     -- Get the raw state and original contents
@@ -212,16 +216,15 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
 
     -- Evaluate the unfortunately-lazy session and headers,
     -- propagating exceptions into the contents
-    (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)
+    (finalSession, contents1) <- evalFallback contents0 (ghsSession state)
-    (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
+    (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
-    contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
 
     -- Convert the HandlerContents into the final YesodResponse
     handleContents
         (handleError rhe yreq resState finalSession headers)
         finalSession
         headers
-        contents3
+        contents2
 
 safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
        -> ErrorResponse
@@ -236,31 +239,31 @@ safeEh log' er req = do
         (toContent ("Internal Server Error" :: S.ByteString))
         (reqSession req)
 
--- | Run a 'HandlerFor' completely outside of Yesod.  This
+-- | Run a 'HandlerT' completely outside of Yesod.  This
 -- function comes with many caveats and you shouldn't use it
 -- unless you fully understand what it's doing and how it works.
 --
 -- As of now, there's only one reason to use this function at
--- all: in order to run unit tests of functions inside 'HandlerFor'
+-- all: in order to run unit tests of functions inside 'HandlerT'
 -- but that aren't easily testable with a full HTTP request.
 -- Even so, it's better to use @wai-test@ or @yesod-test@ instead
 -- of using this function.
 --
 -- This function will create a fake HTTP request (both @wai@'s
 -- 'Request' and @yesod@'s 'Request') and feed it to the
--- @HandlerFor@.  The only useful information the @HandlerFor@ may
+-- @HandlerT@.  The only useful information the @HandlerT@ may
 -- get from the request is the session map, which you must supply
 -- as argument to @runFakeHandler@.  All other fields contain
 -- fake information, which means that they can be accessed but
 -- won't have any useful information.  The response of the
--- @HandlerFor@ is completely ignored, including changes to the
+-- @HandlerT@ is completely ignored, including changes to the
 -- session, cookies or headers.  We only return you the
--- @HandlerFor@'s return value.
+-- @HandlerT@'s return value.
-runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
+runFakeHandler :: (Yesod site, MonadIO m) =>
                   SessionMap
                -> (site -> Logger)
                -> site
-               -> HandlerFor site a
+               -> HandlerT site IO a
                -> m (Either ErrorResponse a)
 runFakeHandler fakeSessionMap logger site handler = liftIO $ do
   ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
@@ -270,14 +273,11 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
          RunHandlerEnv
             { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
             , rheRoute = Nothing
-            , rheRouteToMaster = id
-            , rheChild = site
             , rheSite = site
             , rheUpload = fileUpload site
             , rheLog = messageLoggerSource site $ logger site
             , rheOnError = errHandler
             , rheMaxExpires = maxExpires
-            , rheCatchHandlerExceptions = catchHandlerExceptions site
             }
         handler'
       errHandler err req = do
@@ -303,8 +303,10 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
           , vault          = mempty
           , requestBodyLength = KnownLength 0
           , requestHeaderRange = Nothing
+#if MIN_VERSION_wai(3,2,0)
           , requestHeaderReferer = Nothing
           , requestHeaderUserAgent = Nothing
+#endif
           }
       fakeRequest =
         YesodRequest
@@ -319,51 +321,46 @@ 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
+            => HandlerT site IO res
             -> YesodRunnerEnv site
             -> Maybe (Route site)
             -> Application
-yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
+yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
-  mmaxLen <- maximumContentLengthIO yreSite route
+  | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse tooLargeResponse
-  case (mmaxLen, requestBodyLength req) of
+  | otherwise = do
-    (Just maxLen, KnownLength len) | maxLen < len -> sendResponse (tooLargeResponse maxLen len)
+    let dontSaveSession _ = return []
-    _ -> do
+    (session, saveSession) <- liftIO $
-      let dontSaveSession _ = return []
+        maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend
-      (session, saveSession) <- liftIO $
+    maxExpires <- yreGetMaxExpires
-          maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend
+    let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
-      maxExpires <- yreGetMaxExpires
+    let yreq =
-      let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
+            case mkYesodReq of
-      let yreq =
+                Left yreq' -> yreq'
-              case mkYesodReq of
+                Right needGen -> needGen yreGen
-                  Left yreq' -> yreq'
+    let ra = resolveApproot yreSite req
-                  Right needGen -> needGen yreGen
+    let log' = messageLoggerSource yreSite yreLogger
-      let ra = resolveApproot yreSite req
+        -- We set up two environments: the first one has a "safe" error handler
-      let log' = messageLoggerSource yreSite yreLogger
+        -- which will never throw an exception. The second one uses the
-          -- We set up two environments: the first one has a "safe" error handler
+        -- user-provided errorHandler function. If that errorHandler function
-          -- which will never throw an exception. The second one uses the
+        -- errors out, it will use the safeEh below to recover.
-          -- user-provided errorHandler function. If that errorHandler function
+        rheSafe = RunHandlerEnv
-          -- errors out, it will use the safeEh below to recover.
+            { rheRender = yesodRender yreSite ra
-          rheSafe = RunHandlerEnv
+            , rheRoute = route
-              { rheRender = yesodRender yreSite ra
+            , rheSite = yreSite
-              , rheRoute = route
+            , rheUpload = fileUpload yreSite
-              , rheRouteToMaster = id
+            , rheLog = log'
-              , rheChild = yreSite
+            , rheOnError = safeEh log'
-              , rheSite = yreSite
+            , rheMaxExpires = maxExpires
-              , rheUpload = fileUpload yreSite
+            }
-              , rheLog = log'
+        rhe = rheSafe
-              , rheOnError = safeEh log'
+            { rheOnError = runHandler rheSafe . errorHandler
-              , rheMaxExpires = maxExpires
+            }
-              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite
-              }
-          rhe = rheSafe
-              { rheOnError = runHandler rheSafe . errorHandler
-              }
 
-      yesodWithInternalState yreSite route $ \is -> do
+    yesodWithInternalState yreSite route $ \is -> do
-          yreq' <- yreq
+        yreq' <- yreq
-          yar <- runInternalState (runHandler rhe handler yreq') is
+        yar <- runInternalState (runHandler rhe handler yreq') is
-          yarToResponse yar saveSession yreq' req is sendResponse
+        yarToResponse yar saveSession yreq' req is sendResponse
   where
     mmaxLen = maximumContentLength yreSite route
     handler = yesodMiddleware handler'
@@ -375,7 +372,7 @@ yesodRender :: Yesod y
             -> [(Text, Text)] -- ^ url query string
             -> Text
 yesodRender y ar url params =
-    decodeUtf8With lenientDecode $ BL.toStrict $ toLazyByteString $
+    decodeUtf8With lenientDecode $ toByteString $
     fromMaybe
         (joinPath y ar ps
           $ params ++ params')

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

@@ -0,0 +1,262 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Yesod.Core.Internal.TH where
+
+import Prelude hiding (exp)
+import Yesod.Core.Handler
+
+import Language.Haskell.TH hiding (cxt, instanceD)
+import Language.Haskell.TH.Syntax
+
+import qualified Network.Wai as W
+
+import Data.ByteString.Lazy.Char8 ()
+#if MIN_VERSION_base(4,8,0)
+import Data.List (foldl', uncons)
+#else
+import Data.List (foldl')
+#endif
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative ((<$>))
+#endif
+import Control.Monad (replicateM, void)
+import Data.Either (partitionEithers)
+import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)
+import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
+
+import Yesod.Routes.TH
+import Yesod.Routes.Parse
+import Yesod.Core.Types
+import Yesod.Core.Content
+import Yesod.Core.Class.Dispatch
+import Yesod.Core.Internal.Run
+
+-- | Generates URL datatype and site function for the given 'Resource's. This
+-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
+-- Use 'parseRoutes' to create the 'Resource's.
+mkYesod :: String -- ^ name of the argument datatype
+        -> [ResourceTree String]
+        -> Q [Dec]
+mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False return
+
+mkYesodWith :: String
+            -> [Either String [String]]
+            -> [ResourceTree String]
+            -> Q [Dec]
+mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral name args False return
+
+-- | Sometimes, you will want to declare your routes in one file and define
+-- your handlers elsewhere. For example, this is the only way to break up a
+-- monolithic file into smaller parts. Use this function, paired with
+-- 'mkYesodDispatch', to do just that.
+mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
+mkYesodData name = mkYesodDataGeneral name False
+
+mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
+mkYesodSubData name = mkYesodDataGeneral name True
+
+mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
+mkYesodDataGeneral name isSub res = do
+    let (name', rest, cxt) = case parse parseName "" name of
+            Left err -> error $ show err
+            Right a -> a
+    fst <$> mkYesodGeneral' cxt name' (fmap Left rest) isSub return res
+
+    where
+        parseName = do
+            cxt <- option [] parseContext
+            name' <- parseWord
+            args <- many parseWord
+            spaces
+            eof
+            return ( name', args, cxt)
+
+        parseWord = do
+            spaces
+            many1 alphaNum
+
+        parseContext = try $ do
+            cxts <- parseParen parseContexts
+            spaces
+            _ <- string "=>"
+            return cxts
+
+        parseParen p = do
+            spaces
+            _ <- char '('
+            r <- p
+            spaces
+            _ <- char ')'
+            return r
+
+        parseContexts = 
+            sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
+
+-- | See 'mkYesodData'.
+mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
+mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return
+
+-- | Get the Handler and Widget type synonyms for the given site.
+masterTypeSyns :: [Name] -> Type -> [Dec]
+masterTypeSyns vs site =
+    [ TySynD (mkName "Handler") (fmap PlainTV vs)
+      $ ConT ''HandlerT `AppT` site `AppT` ConT ''IO
+    , TySynD (mkName "Widget")  (fmap PlainTV vs)
+      $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
+    ]
+
+-- | 'Left' arguments indicate a monomorphic type, a 'Right' argument
+--   indicates a polymorphic type, and provides the list of classes
+--   the type must be instance of.
+mkYesodGeneral :: String                    -- ^ foundation type
+               -> [Either String [String]]  -- ^ arguments for the type
+               -> Bool                      -- ^ is this a subsite
+               -> (Exp -> Q Exp)            -- ^ unwrap handler
+               -> [ResourceTree String]
+               -> Q([Dec],[Dec])
+mkYesodGeneral = mkYesodGeneral' []
+
+mkYesodGeneral' :: [[String]]               -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
+               -> String                    -- ^ foundation type
+               -> [Either String [String]]  -- ^ arguments for the type
+               -> Bool                      -- ^ is this a subsite
+               -> (Exp -> Q Exp)            -- ^ unwrap handler
+               -> [ResourceTree String]
+               -> Q([Dec],[Dec])
+mkYesodGeneral' appCxt' namestr args isSub f resS = do
+    let appCxt = fmap (\(c:rest) -> 
+#if MIN_VERSION_template_haskell(2,10,0)
+            foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
+#else
+            ClassP (mkName c) $ fmap nameToType rest
+#endif
+          ) appCxt'
+    mname <- lookupTypeName namestr
+    arity <- case mname of
+               Just name -> do
+                 info <- reify name
+                 return $
+                   case info of
+                     TyConI dec ->
+                       case dec of
+#if MIN_VERSION_template_haskell(2,11,0)
+                         DataD _ _ vs _ _ _ -> length vs
+                         NewtypeD _ _ vs _ _ _ -> length vs
+#else
+                         DataD _ _ vs _ _ -> length vs
+                         NewtypeD _ _ vs _ _ -> length vs
+#endif
+                         _ -> 0
+                     _ -> 0
+               _ -> return 0
+    let name = mkName namestr
+        (mtys,_) = partitionEithers args
+    -- Generate as many variable names as the arity indicates
+    vns <- replicateM (arity - length mtys) $ newName "t"
+        -- Base type (site type with variables)
+    let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $
+          foldr (\arg (xs,vns',cs) ->
+                   case arg of
+                     Left  t  -> 
+                                 ( nameToType t:xs, vns', cs )
+                     Right ts -> 
+                                 let (n, ns) = maybe (error "mkYesodGeneral: Should be unreachable.") id $ uncons vns' in
+                                 ( VarT n : xs, ns
+                                 , fmap (\t ->
+#if MIN_VERSION_template_haskell(2,10,0)
+                                               AppT (ConT $ mkName t) (VarT n)
+#else
+                                               ClassP (mkName t) [VarT n]
+#endif
+                                          ) ts ++ cs )
+                 ) ([],vns,[]) args
+        site = foldl' AppT (ConT name) argtypes
+        res = map (fmap (parseType . dropBracket)) resS
+    renderRouteDec <- mkRenderRouteInstance' appCxt site res
+    routeAttrsDec  <- mkRouteAttrsInstance' appCxt site res
+    dispatchDec    <- mkDispatchInstance site cxt f res
+    parseRoute <- mkParseRouteInstance' appCxt site res
+    let rname = mkName $ "resources" ++ namestr
+    eres <- lift resS
+    let resourcesDec =
+            [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
+            , FunD rname [Clause [] (NormalB eres) []]
+            ]
+    let dataDec = concat
+            [ [parseRoute]
+            , renderRouteDec
+            , [routeAttrsDec]
+            , resourcesDec
+            , if isSub then [] else masterTypeSyns vns site
+            ]
+    return (dataDec, dispatchDec)
+
+#if !MIN_VERSION_base(4,8,0)
+    where
+        uncons (h:t) = Just (h,t)
+        uncons _ = Nothing
+#endif
+
+mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
+mkMDS f rh = MkDispatchSettings
+    { mdsRunHandler = rh
+    , 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|]
+    , mds404 = [|void notFound|]
+    , mds405 = [|void badMethod|]
+    , mdsGetHandler = defaultGetHandler
+    , mdsUnwrapper = f
+    }
+
+-- | If the generation of @'YesodDispatch'@ instance require finer
+-- control of the types, contexts etc. using this combinator. You will
+-- hardly need this generality. However, in certain situations, like
+-- when writing library/plugin for yesod, this combinator becomes
+-- handy.
+mkDispatchInstance :: Type                      -- ^ The master site type
+                   -> Cxt                       -- ^ Context of the instance
+                   -> (Exp -> Q Exp)            -- ^ Unwrap handler
+                   -> [ResourceTree c]          -- ^ The resource
+                   -> DecsQ
+mkDispatchInstance master cxt f res = do
+    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 . fmap toTypedContent|]) res
+    inner <- newName "inner"
+    let innerFun = FunD inner [clause']
+    helper <- newName "helper"
+    let fun = FunD helper
+                [ Clause
+                    []
+                    (NormalB $ VarE inner)
+                    [innerFun]
+                ]
+    return $ LetE [fun] (VarE helper)
+
+instanceD :: Cxt -> Type -> [Dec] -> Dec
+#if MIN_VERSION_template_haskell(2,11,0)
+instanceD = InstanceD Nothing
+#else
+instanceD = InstanceD
+#endif

yesod-core/Yesod/Core/Json.hs

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

yesod-core/Yesod/Core/TypeCache.hs

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

yesod-core/Yesod/Core/Types.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleInstances          #-}
@@ -7,29 +7,32 @@
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
 module Yesod.Core.Types where
 
-import Data.Aeson (ToJSON)
+import qualified Blaze.ByteString.Builder           as BBuilder
-import qualified Data.ByteString.Builder            as BB
+import qualified Blaze.ByteString.Builder.Char.Utf8
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative                (Applicative (..))
+import           Control.Applicative                ((<$>))
+import           Data.Monoid                        (Monoid (..))
+#endif
 import           Control.Arrow                      (first)
 import           Control.Exception                  (Exception)
-import           Control.Monad                      (ap)
+import           Control.Monad                      (liftM, ap)
+import           Control.Monad.Base                 (MonadBase (liftBase))
+import           Control.Monad.Catch                (MonadMask (..), MonadCatch (..))
 import           Control.Monad.IO.Class             (MonadIO (liftIO))
 import           Control.Monad.Logger               (LogLevel, LogSource,
                                                      MonadLogger (..))
-import           Control.Monad.Primitive            (PrimMonad (..))
+import           Control.Monad.Trans.Control        (MonadBaseControl (..))
-import           Control.Monad.Trans.Resource       (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)
+import           Control.Monad.Trans.Resource       (MonadResource (..), InternalState, runInternalState, MonadThrow (..), monadThrow, ResourceT)
 import           Data.ByteString                    (ByteString)
 import qualified Data.ByteString.Lazy               as L
-import           Data.CaseInsensitive               (CI)
+import           Data.Conduit                       (Flush, Source)
-import           Data.Conduit                       (Flush, ConduitT)
+import           Data.IORef                         (IORef)
-import           Data.IORef                         (IORef, modifyIORef')
 import           Data.Map                           (Map, unionWith)
 import qualified Data.Map                           as Map
 import           Data.Monoid                        (Endo (..), Last (..))
-import           Data.Semigroup                     (Semigroup(..))
 import           Data.Serialize                     (Serialize (..),
                                                      putByteString)
 import           Data.String                        (IsString (fromString))
@@ -37,6 +40,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
@@ -45,18 +49,22 @@ import           Network.Wai                        (FilePart,
 import qualified Network.Wai                        as W
 import qualified Network.Wai.Parse                  as NWP
 import           System.Log.FastLogger              (LogStr, LoggerSet, toLogStr, pushLogStr)
+import qualified System.Random.MWC                  as MWC
 import           Network.Wai.Logger                 (DateCacheGetter)
 import           Text.Blaze.Html                    (Html, toHtml)
 import           Text.Hamlet                        (HtmlUrl)
 import           Text.Julius                        (JavascriptUrl)
 import           Web.Cookie                         (SetCookie)
 import           Yesod.Core.Internal.Util           (getTime, putTime)
+import           Control.Monad.Trans.Class          (MonadTrans (..))
 import           Yesod.Routes.Class                 (RenderRoute (..), ParseRoute (..))
 import           Control.Monad.Reader               (MonadReader (..))
 import Control.DeepSeq (NFData (rnf))
+import Control.DeepSeq.Generics (genericRnf)
+import Data.Conduit.Lazy (MonadActive, monadActive)
 import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
 import Control.Monad.Logger (MonadLoggerIO (..))
-import UnliftIO (MonadUnliftIO (..), SomeException)
+import Data.Semigroup (Semigroup)
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -69,7 +77,7 @@ newtype SessionBackend = SessionBackend
                     -> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session
     }
 
-data SessionCookie = SessionCookie !(Either UTCTime ByteString) !ByteString !SessionMap
+data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString SessionMap
     deriving (Show, Read)
 instance Serialize SessionCookie where
     put (SessionCookie a b c) = do
@@ -127,13 +135,13 @@ type RequestBodyContents =
 data FileInfo = FileInfo
     { fileName        :: !Text
     , fileContentType :: !Text
-    , fileSourceRaw   :: !(ConduitT () ByteString (ResourceT IO) ())
+    , fileSourceRaw   :: !(Source (ResourceT IO) ByteString)
     , fileMove        :: !(FilePath -> IO ())
     }
 
 data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
                 | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)
-                | FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ()))
+                | FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))
 
 -- | How to determine the root of the application for constructing URLs.
 --
@@ -147,13 +155,13 @@ data Approot master = ApprootRelative -- ^ No application root.
 
 type ResolvedApproot = Text
 
-data AuthResult = Authorized | AuthenticationRequired | Unauthorized !Text
+data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
     deriving (Eq, Show, Read)
 
 data ScriptLoadPosition master
     = BottomOfBody
     | BottomOfHeadBlocking
-    | BottomOfHeadAsync !(BottomOfHeadAsync master)
+    | BottomOfHeadAsync (BottomOfHeadAsync master)
 
 type BottomOfHeadAsync master
        = [Text] -- ^ urls to load asynchronously
@@ -166,16 +174,14 @@ type Texts = [Text]
 newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
 
 -- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized.
---
+-- 
 -- @since 1.4.34
 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }
 
-data RunHandlerEnv child site = RunHandlerEnv
+data RunHandlerEnv site = RunHandlerEnv
     { rheRender   :: !(Route site -> [(Text, Text)] -> Text)
-    , rheRoute    :: !(Maybe (Route child))
+    , rheRoute    :: !(Maybe (Route site))
-    , rheRouteToMaster :: !(Route child -> Route site)
     , rheSite     :: !site
-    , rheChild    :: !child
     , rheUpload   :: !(RequestBodyLength -> FileUpload)
     , rheLog      :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
     , rheOnError  :: !(ErrorResponse -> YesodApp)
@@ -183,17 +189,13 @@ 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
+data HandlerData site parentRoute = HandlerData
     { handlerRequest  :: !YesodRequest
-    , handlerEnv      :: !(RunHandlerEnv child site)
+    , handlerEnv      :: !(RunHandlerEnv site)
     , handlerState    :: !(IORef GHState)
+    , handlerToParent :: !(Route site -> parentRoute)
     , handlerResource :: !InternalState
     }
 
@@ -201,83 +203,68 @@ data YesodRunnerEnv site = YesodRunnerEnv
     { yreLogger         :: !Logger
     , yreSite           :: !site
     , yreSessionBackend :: !(Maybe SessionBackend)
-    , yreGen            :: !(IO Int)
+    , yreGen            :: !MWC.GenIO
-    -- ^ Generate a random number uniformly distributed in the full
+    , yreGetMaxExpires  :: IO Text
-    -- range of 'Int'.
-    --
-    -- Note: Before 1.6.20, the default value generates pseudo-random
-    -- number in an unspecified range. The range size may not be a power
-    -- of 2. Since 1.6.20, the default value uses a secure entropy source
-    -- and generates in the full range of 'Int'.
-    , yreGetMaxExpires  :: !(IO Text)
     }
 
-data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv
+data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv
-    { ysreParentRunner  :: !(ParentRunner parent)
+    { ysreParentRunner  :: !(ParentRunner parent parentMonad)
     , ysreGetSub        :: !(parent -> sub)
     , ysreToParentRoute :: !(Route sub -> Route parent)
     , ysreParentEnv     :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner?
     }
 
-type ParentRunner parent
+type ParentRunner parent m
-    = HandlerFor parent TypedContent
+    = m TypedContent
    -> YesodRunnerEnv parent
    -> Maybe (Route parent)
    -> W.Application
 
 -- | A generic handler monad, which can have a different subsite and master
 -- site. We define a newtype for better error message.
-newtype HandlerFor site a = HandlerFor
+newtype HandlerT site m a = HandlerT
-    { unHandlerFor :: HandlerData site site -> IO a
+    { unHandlerT :: HandlerData site (MonadRoute m) -> m a
     }
-    deriving Functor
+
+type family MonadRoute (m :: * -> *)
+type instance MonadRoute IO = ()
+type instance MonadRoute (HandlerT site m) = (Route site)
 
 data GHState = GHState
-    { ghsSession :: !SessionMap
+    { ghsSession :: SessionMap
-    , ghsRBC     :: !(Maybe RequestBodyContents)
+    , ghsRBC     :: Maybe RequestBodyContents
-    , ghsIdent   :: !Int
+    , ghsIdent   :: Int
-    , ghsCache   :: !TypeMap
+    , ghsCache   :: TypeMap
-    , ghsCacheBy :: !KeyedTypeMap
+    , ghsCacheBy :: KeyedTypeMap
-    , ghsHeaders :: !(Endo [Header])
+    , ghsHeaders :: Endo [Header]
     }
 
 -- | An extension of the basic WAI 'W.Application' datatype to provide extra
 -- features needed by Yesod. Users should never need to use this directly, as
--- the 'HandlerFor' monad and template haskell code should hide it away.
+-- the 'HandlerT' monad and template haskell code should hide it away.
 type YesodApp = YesodRequest -> ResourceT IO YesodResponse
 
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. While this is simply a @WriterT@, we define a newtype for
 -- better error messages.
-newtype WidgetFor site a = WidgetFor
+newtype WidgetT site m a = WidgetT
-    { unWidgetFor :: WidgetData site -> IO a
+    { unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site))
     }
-    deriving Functor
 
-data WidgetData site = WidgetData
+instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
-  { wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))
-  , wdHandler :: {-# UNPACK #-} !(HandlerData site site)
-  }
-
-instance a ~ () => Monoid (WidgetFor site a) where
     mempty = return ()
-#if !(MIN_VERSION_base(4,11,0))
+    mappend x y = x >> y
-    mappend = (<>)
+instance (a ~ (), Monad m) => Semigroup (WidgetT site m a)
-#endif
-instance a ~ () => Semigroup (WidgetFor site a) where
-    x <> y = x >> y
 
 -- | A 'String' can be trivially promoted to a widget.
 --
 -- For example, in a yesod-scaffold site you could use:
 --
 -- @getHomeR = do defaultLayout "Widget text"@
-instance a ~ () => IsString (WidgetFor site a) where
+instance (Monad m, a ~ ()) => IsString (WidgetT site m a) where
     fromString = toWidget . toHtml . T.pack
-      where toWidget x = tellWidget mempty { gwdBody = Body (const x) }
+      where toWidget x = WidgetT $ const $ return ((), GWData (Body (const x))
-
+                         mempty mempty mempty mempty mempty mempty)
-tellWidget :: GWData (Route site) -> WidgetFor site ()
-tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d)
 
 type RY master = Route master -> [(Text, Text)] -> Text
 
@@ -295,14 +282,13 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
 --
 -- > PageContent url -> HtmlUrl url
 data PageContent url = PageContent
-    { pageTitle       :: !Html
+    { pageTitle :: Html
-    , pageDescription :: !(Maybe Text)
+    , pageHead  :: HtmlUrl url
-    , pageHead        :: !(HtmlUrl url)
+    , pageBody  :: HtmlUrl url
-    , pageBody        :: !(HtmlUrl url)
     }
 
-data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
+data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length.
-             | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())
+             | ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder))
              | ContentFile !FilePath !(Maybe FilePart)
              | ContentDontEvaluate !Content
 
@@ -316,20 +302,6 @@ newtype RepXml = RepXml Content
 
 type ContentType = ByteString -- FIXME Text?
 
--- | Wrapper around types so that Handlers can return a domain type, even when
--- the data will eventually be encoded as JSON.
--- Example usage in a type signature:
---
--- > postSignupR :: Handler (JSONResponse CreateUserResponse)
---
--- And in the implementation:
---
--- > return $ JSONResponse $ CreateUserResponse userId
---
--- @since 1.6.14
-data JSONResponse a where
-    JSONResponse :: ToJSON a => a -> JSONResponse a
-
 -- | Prevents a response body from being fully evaluated before sending the
 -- request.
 --
@@ -339,39 +311,21 @@ newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
 -- | Responses to indicate some form of an error occurred.
 data ErrorResponse =
       NotFound
-        -- ^ The requested resource was not found.
+    | InternalError Text
-        -- Examples of when this occurs include when an incorrect URL is used, or @yesod-persistent@'s 'get404' doesn't find a value.
+    | InvalidArgs [Text]
-        -- 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.
+    | PermissionDenied Text
-        -- This is thrown when 'isAuthorized' returns 'AuthenticationRequired'.
+    | BadMethod H.Method
-        -- HTTP code: 401.
+    deriving (Show, Eq, Typeable, Generic)
-    | PermissionDenied !Text
+instance NFData ErrorResponse where
-        -- ^ Indicates the user doesn't have permission to access the requested resource.
+    rnf = genericRnf
-        -- 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)
-instance NFData ErrorResponse
 
 ----- header stuff
 -- | Headers to be added to a 'Result'.
 data Header =
-      AddCookie !SetCookie
+      AddCookie SetCookie
-    | DeleteCookie !ByteString !ByteString
+    | DeleteCookie ByteString ByteString
-    -- ^ name and path
+    | Header ByteString ByteString
-    | Header !(CI ByteString) !ByteString
-    -- ^ key and value
     deriving (Eq, Show)
 
 -- FIXME In the next major version bump, let's just add strictness annotations
@@ -382,35 +336,31 @@ instance NFData Header where
     rnf (DeleteCookie x y) = x `seq` y `seq` ()
     rnf (Header x y) = x `seq` y `seq` ()
 
-data Location url = Local !url | Remote !Text
+data Location url = Local url | Remote Text
     deriving (Show, Eq)
 
 -- | A diff list that does not directly enforce uniqueness.
 -- When creating a widget Yesod will use nub to make it unique.
 newtype UniqueList x = UniqueList ([x] -> [x])
 
-data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :: ![(Text, Text)] }
+data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }
     deriving (Show, Eq)
-data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }
+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
-instance Semigroup (Head url) where
+instance Semigroup (Head a)
-  (<>) = mappend
 newtype Body url = Body (HtmlUrl url)
     deriving Monoid
-instance Semigroup (Body url) where
+instance Semigroup (Body a)
-  (<>) = mappend
 
 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,30 +368,27 @@ 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 (GWData a1 a2 a3 a4 a5 a6 a7)
-    mappend = (<>)
+            (GWData b1 b2 b3 b4 b5 b6 b7) = GWData
-#endif
+        (a1 `mappend` b1)
-instance Semigroup (GWData a) where
+        (a2 `mappend` b2)
-    GWData a1 a2 a3 a4 a5 a6 a7 a8 <>
+        (a3 `mappend` b3)
-      GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData
+        (a4 `mappend` b4)
-        (mappend a1 b1)
+        (unionWith mappend a5 b5)
-        (mappend a2 b2)
+        (a6 `mappend` b6)
-        (mappend a3 b3)
+        (a7 `mappend` b7)
-        (mappend a4 b4)
+instance Semigroup (GWData a)
-        (mappend a5 b5)
-        (unionWith mappend a6 b6)
-        (mappend a7 b7)
-        (mappend a8 b8)
 
 data HandlerContents =
-      HCContent !H.Status !TypedContent
+      HCContent H.Status !TypedContent
-    | HCError !ErrorResponse
+    | HCError ErrorResponse
-    | HCSendFile !ContentType !FilePath !(Maybe FilePart)
+    | HCSendFile ContentType FilePath (Maybe FilePart)
-    | HCRedirect !H.Status !Text
+    | HCRedirect H.Status Text
-    | HCCreated !Text
+    | HCCreated Text
-    | HCWai !W.Response
+    | HCWai W.Response
-    | HCWaiApp !W.Application
+    | HCWaiApp W.Application
+    deriving Typeable
 
 instance Show HandlerContents where
     show (HCContent status (TypedContent t _)) = "HCContent " ++ show (status, t)
@@ -453,87 +400,137 @@ instance Show HandlerContents where
     show (HCWaiApp _) = "HCWaiApp"
 instance Exception HandlerContents
 
--- Instances for WidgetFor
+-- Instances for WidgetT
-instance Applicative (WidgetFor site) where
+instance Monad m => Functor (WidgetT site m) where
-    pure = WidgetFor . const . pure
+    fmap = liftM
+instance Monad m => Applicative (WidgetT site m) where
+    pure = return
     (<*>) = ap
-instance Monad (WidgetFor site) where
+instance Monad m => Monad (WidgetT site m) where
-    return = pure
+    return a = WidgetT $ const $ return (a, mempty)
-    WidgetFor x >>= f = WidgetFor $ \wd -> do
+    WidgetT x >>= f = WidgetT $ \r -> do
-        a <- x wd
+        (a, wa) <- x r
-        unWidgetFor (f a) wd
+        (b, wb) <- unWidgetT (f a) r
-instance MonadIO (WidgetFor site) where
+        return (b, wa `mappend` wb)
-    liftIO = WidgetFor . const
+instance MonadIO m => MonadIO (WidgetT site m) where
--- | @since 1.6.7
+    liftIO = lift . liftIO
-instance PrimMonad (WidgetFor site) where
+instance MonadBase b m => MonadBase b (WidgetT site m) where
-    type PrimState (WidgetFor site) = PrimState IO
+    liftBase = WidgetT . const . liftBase . fmap (, mempty)
-    primitive = liftIO . primitive
+instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
--- | @since 1.4.38
+    type StM (WidgetT site m) a = StM m (a, GWData (Route site))
-instance MonadUnliftIO (WidgetFor site) where
+    liftBaseWith f = WidgetT $ \reader' ->
-  {-# INLINE withRunInIO #-}
+        liftBaseWith $ \runInBase ->
-  withRunInIO inner = WidgetFor $ \x -> inner $ flip unWidgetFor x
+            fmap (\x -> (x, mempty))
-instance MonadReader (WidgetData site) (WidgetFor site) where
+            (f $ runInBase . flip unWidgetT reader')
-    ask = WidgetFor return
+    restoreM = WidgetT . const . restoreM
-    local f (WidgetFor g) = WidgetFor $ g . f
+instance Monad m => MonadReader site (WidgetT site m) where
+    ask = WidgetT $ \hd -> return (rheSite $ handlerEnv hd, mempty)
+    local f (WidgetT g) = WidgetT $ \hd -> g hd
+        { handlerEnv = (handlerEnv hd)
+            { rheSite = f $ rheSite $ handlerEnv hd
+            }
+        }
 
-instance MonadThrow (WidgetFor site) where
+instance MonadTrans (WidgetT site) where
-    throwM = liftIO . throwM
+    lift = WidgetT . const . liftM (, mempty)
+instance MonadThrow m => MonadThrow (WidgetT site m) where
+    throwM = lift . throwM
 
-instance MonadResource (WidgetFor site) where
+instance MonadCatch m => MonadCatch (HandlerT site m) where
-    liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler
+  catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r
+instance MonadMask m => MonadMask (HandlerT site m) where
+  mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e
+    where q u (HandlerT b) = HandlerT (u . b)
+  uninterruptibleMask a =
+    HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e
+      where q u (HandlerT b) = HandlerT (u . b)
+instance MonadCatch m => MonadCatch (WidgetT site m) where
+  catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r
+instance MonadMask m => MonadMask (WidgetT site m) where
+  mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e
+    where q u (WidgetT b) = WidgetT (u . b)
+  uninterruptibleMask a =
+    WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e
+      where q u (WidgetT b) = WidgetT (u . b)
 
-instance MonadLogger (WidgetFor site) where
+-- CPP to avoid a redundant constraints warning
-    monadLoggerLog a b c d = WidgetFor $ \wd ->
+#if MIN_VERSION_base(4,9,0)
-        rheLog (handlerEnv $ wdHandler wd) a b c (toLogStr d)
+instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
+#else
+instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
+#endif
+    liftResourceT f = WidgetT $ \hd -> liftIO $ (, mempty) <$> runInternalState f (handlerResource hd)
 
-instance MonadLoggerIO (WidgetFor site) where
+instance MonadIO m => MonadLogger (WidgetT site m) where
-    askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
+    monadLoggerLog a b c d = WidgetT $ \hd ->
+        liftIO $ (, mempty) <$> rheLog (handlerEnv hd) a b c (toLogStr d)
 
--- Instances for HandlerFor
+instance MonadIO m => MonadLoggerIO (WidgetT site m) where
-instance Applicative (HandlerFor site) where
+    askLoggerIO = WidgetT $ \hd -> return (rheLog (handlerEnv hd), mempty)
-    pure = HandlerFor . const . return
+
+instance MonadActive m => MonadActive (WidgetT site m) where
+    monadActive = lift monadActive
+instance MonadActive m => MonadActive (HandlerT site m) where
+    monadActive = lift monadActive
+
+instance MonadTrans (HandlerT site) where
+    lift = HandlerT . const
+
+-- Instances for HandlerT
+instance Monad m => Functor (HandlerT site m) where
+    fmap = liftM
+instance Monad m => Applicative (HandlerT site m) where
+    pure = return
     (<*>) = ap
-instance Monad (HandlerFor site) where
+instance Monad m => Monad (HandlerT site m) where
-    return = pure
+    return = HandlerT . const . return
-    HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r
+    HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r
-instance MonadIO (HandlerFor site) where
+instance MonadIO m => MonadIO (HandlerT site m) where
-    liftIO = HandlerFor . const
+    liftIO = lift . liftIO
--- | @since 1.6.7
+instance MonadBase b m => MonadBase b (HandlerT site m) where
-instance PrimMonad (HandlerFor site) where
+    liftBase = lift . liftBase
-    type PrimState (HandlerFor site) = PrimState IO
+instance Monad m => MonadReader site (HandlerT site m) where
-    primitive = liftIO . primitive
+    ask = HandlerT $ return . rheSite . handlerEnv
-instance MonadReader (HandlerData site site) (HandlerFor site) where
+    local f (HandlerT g) = HandlerT $ \hd -> g hd
-    ask = HandlerFor return
+        { handlerEnv = (handlerEnv hd)
-    local f (HandlerFor g) = HandlerFor $ g . f
+            { rheSite = f $ rheSite $ handlerEnv hd
+            }
+        }
+-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
+-- @fork@ function is incompatible with the underlying @ResourceT@ system.
+-- Instead, if you must fork a separate thread, you should use
+-- @resourceForkIO@.
+--
+-- Using fork usually leads to an exception that says
+-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed
+-- after cleanup. Please contact the maintainers.\"
+instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
+    type StM (HandlerT site m) a = StM m a
+    liftBaseWith f = HandlerT $ \reader' ->
+        liftBaseWith $ \runInBase ->
+            f $ runInBase . (\(HandlerT r) -> r reader')
+    restoreM = HandlerT . const . restoreM
 
--- | @since 1.4.38
+instance MonadThrow m => MonadThrow (HandlerT site m) where
-instance MonadUnliftIO (HandlerFor site) where
+    throwM = lift . monadThrow
-  {-# INLINE withRunInIO #-}
-  withRunInIO inner = HandlerFor $ \x -> inner $ flip unHandlerFor x
 
-instance MonadThrow (HandlerFor site) where
+instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where
-    throwM = liftIO . throwM
+    liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
 
-instance MonadResource (HandlerFor site) where
+instance MonadIO m => MonadLogger (HandlerT site m) where
-    liftResourceT f = HandlerFor $ runInternalState f . handlerResource
+    monadLoggerLog a b c d = HandlerT $ \hd ->
+        liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
 
-instance MonadLogger (HandlerFor site) where
+instance MonadIO m => MonadLoggerIO (HandlerT site m) where
-    monadLoggerLog a b c d = HandlerFor $ \hd ->
+    askLoggerIO = HandlerT $ \hd -> return (rheLog (handlerEnv hd))
-        rheLog (handlerEnv hd) a b c (toLogStr d)
-
-instance MonadLoggerIO (HandlerFor site) where
-    askLoggerIO = HandlerFor $ \hd -> return (rheLog (handlerEnv hd))
 
 instance Monoid (UniqueList x) where
     mempty = UniqueList id
-#if !(MIN_VERSION_base(4,11,0))
+    UniqueList x `mappend` UniqueList y = UniqueList $ x . y
-    mappend = (<>)
+instance Semigroup (UniqueList x)
-#endif
-instance Semigroup (UniqueList x) where
-    UniqueList x <> UniqueList y = UniqueList $ x . y
 
 instance IsString Content where
-    fromString = flip ContentBuilder Nothing . BB.stringUtf8
+    fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString
 
 instance RenderRoute WaiSubsite where
     data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]
@@ -557,41 +554,3 @@ data Logger = Logger
 
 loggerPutStr :: Logger -> LogStr -> IO ()
 loggerPutStr (Logger ls _) = pushLogStr ls
-
--- | A handler monad for subsite
---
--- @since 1.6.0
-newtype SubHandlerFor sub master a = SubHandlerFor
-    { unSubHandlerFor :: HandlerData sub master -> IO a
-    }
-    deriving Functor
-
-instance Applicative (SubHandlerFor child master) where
-    pure = SubHandlerFor . const . return
-    (<*>) = ap
-instance Monad (SubHandlerFor child master) where
-    return = pure
-    SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r
-instance MonadIO (SubHandlerFor child master) where
-    liftIO = SubHandlerFor . const
-instance MonadReader (HandlerData child master) (SubHandlerFor child master) where
-    ask = SubHandlerFor return
-    local f (SubHandlerFor g) = SubHandlerFor $ g . f
-
--- | @since 1.4.38
-instance MonadUnliftIO (SubHandlerFor child master) where
-  {-# INLINE withRunInIO #-}
-  withRunInIO inner = SubHandlerFor $ \x -> inner $ flip unSubHandlerFor x
-
-instance MonadThrow (SubHandlerFor child master) where
-    throwM = liftIO . throwM
-
-instance MonadResource (SubHandlerFor child master) where
-    liftResourceT f = SubHandlerFor $ runInternalState f . handlerResource
-
-instance MonadLogger (SubHandlerFor child master) where
-    monadLoggerLog a b c d = SubHandlerFor $ \sd ->
-        rheLog (handlerEnv sd) a b c (toLogStr d)
-
-instance MonadLoggerIO (SubHandlerFor child master) where
-    askLoggerIO = SubHandlerFor $ return . rheLog . handlerEnv

yesod-core/Yesod/Core/Unsafe.hs

@@ -1,6 +1,7 @@
+{-# LANGUAGE CPP #-}
 -- | This is designed to be used as
 --
--- > import qualified Yesod.Core.Unsafe as Unsafe
+-- > qualified import Yesod.Core.Unsafe as Unsafe
 --
 -- This serves as a reminder that the functions are unsafe to use in many situations.
 module Yesod.Core.Unsafe (runFakeHandler, fakeHandlerGetLogger) where
@@ -9,16 +10,16 @@ import Yesod.Core.Internal.Run (runFakeHandler)
 
 import Yesod.Core.Types
 import Yesod.Core.Class.Yesod
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid            (mempty, mappend)
+#endif
 import Control.Monad.IO.Class (MonadIO)
 
 -- | designed to be used as
 --
 -- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 fakeHandlerGetLogger :: (Yesod site, MonadIO m)
-                     => (site -> Logger)
+                     => (site -> Logger) -> site -> HandlerT site IO a -> m a
-                     -> site
-                     -> HandlerFor site a
-                     -> m a
 fakeHandlerGetLogger getLogger app f =
      runFakeHandler mempty getLogger app f
  >>= either (error . ("runFakeHandler issue: " `mappend`) . show)

yesod-core/Yesod/Core/Widget.hs

@@ -8,14 +8,12 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
-
 -- | 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
     ( -- * Datatype
       WidgetT
-    , WidgetFor
     , PageContent (..)
       -- * Special Hamlet quasiquoter/TH for Widgets
     , whamlet
@@ -31,12 +29,6 @@ module Yesod.Core.Widget
       -- ** Head of page
     , setTitle
     , setTitleI
-    , setDescription
-    , setDescriptionI
-    , setDescriptionIdemp
-    , setDescriptionIdempI
-    , setOGType
-    , setOGImage
       -- ** CSS
     , addStylesheet
     , addStylesheetAttrs
@@ -51,6 +43,7 @@ module Yesod.Core.Widget
     , addScriptRemoteAttrs
     , addScriptEither
       -- * Subsites
+    , widgetToParentWidget
     , handlerToWidget
       -- * Internal
     , whamletFileWithSettings
@@ -64,9 +57,13 @@ import Text.Cassius
 import Text.Julius
 import Yesod.Routes.Class
 import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative ((<$>))
+#endif
+import Control.Monad (liftM)
+import Control.Monad.IO.Class (MonadIO, liftIO)
 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,9 +77,6 @@ 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
-{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
-
 preEscapedLazyText :: TL.Text -> Html
 preEscapedLazyText = preEscapedToMarkup
 
@@ -90,21 +84,21 @@ 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
+instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where
-    toWidget = liftWidget
+    toWidget = liftWidgetT
 instance ToWidget site Html where
     toWidget = toWidget . const
 -- | @since 1.4.28
@@ -133,9 +127,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 +147,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 +163,18 @@ instance ToWidgetHead site Javascript where
 instance ToWidgetHead site Html where
     toWidgetHead = toWidgetHead . const
 
--- | Set the page title.
+-- | Set the page title. Calling 'setTitle' multiple times overrides previously
---
+-- set values.
--- Calling @setTitle@ or @setTitleI@ multiple times overrides previously set
--- values.
---
--- SEO Notes:
---
---    * Title tags are the second most important on-page factor for SEO, after
---      content
---    * Every page should have a unique title tag
---    * Start your title tag with your main targeted keyword
---    * Don't stuff your keywords
---    * Google typically shows 55-64 characters, so aim to keep your title
---      length under 60 characters
 setTitle :: MonadWidget m => Html -> m ()
-setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty
+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
 
--- | Set the localised page title.
+-- | Set the page title. Calling 'setTitle' multiple times overrides previously
---
+-- set values.
--- n.b. See comments for @setTitle@
 setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
 setTitleI msg = do
     mr <- getMessageRender
     setTitle $ toHtml $ mr msg
 
--- | Add description meta tag to the head of the page
---
--- Google does not use the description tag as a ranking signal, but the
--- contents of this tag will likely affect your click-through rate since it
--- shows up in search results.
---
--- The average length of the description shown in Google's search results is
--- about 160 characters on desktop, and about 130 characters on mobile, at time
--- of writing.
---
--- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
---
--- @since 1.6.18
-setDescription :: MonadWidget m => Text -> m ()
-setDescription description =
-    toWidgetHead $ [hamlet|<meta name=description content=#{description}>|]
-
-{-# WARNING setDescription
-  [ "setDescription is not idempotent; we recommend setDescriptionIdemp instead"
-  , "Multiple calls to setDescription will insert multiple meta tags in the page head."
-  , "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \
-    \may need to change your layout to include pageDescription."
-  ]
-#-}
-
--- | Add translated description meta tag to the head of the page
---
--- n.b. See comments for @setDescription@.
---
--- @since 1.6.18
-setDescriptionI
-  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)
-  => msg -> m ()
-setDescriptionI msg = do
-    mr <- getMessageRender
-    toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|]
-
-{-# WARNING setDescriptionI
-  [ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead"
-  , "Multiple calls to setDescriptionI will insert multiple meta tags in the page head."
-  , "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \
-    \may need to change your layout to include pageDescription."
-  ]
-#-}
-
--- | Add description meta tag to the head of the page
---
--- Google does not use the description tag as a ranking signal, but the
--- contents of this tag will likely affect your click-through rate since it
--- shows up in search results.
---
--- The average length of the description shown in Google's search results is
--- about 160 characters on desktop, and about 130 characters on mobile, at time
--- of writing.
---
--- Unlike 'setDescription', this version is *idempotent* - calling it multiple
--- times will result in only a single description meta tag in the head.
---
--- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
---
--- @since 1.6.23
-setDescriptionIdemp :: MonadWidget m => Text -> m ()
-setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty
-
--- | Add translated description meta tag to the head of the page
---
--- n.b. See comments for @setDescriptionIdemp@.
---
--- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple
--- times will result in only a single description meta tag in the head.
---
--- @since 1.6.23
-setDescriptionIdempI
-  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)
-  => msg -> m ()
-setDescriptionIdempI msg = do
-    mr <- getMessageRender
-    setDescriptionIdemp $ mr msg
-
--- | Add OpenGraph type meta tag to the head of the page
---
--- See all available OG types here: https://ogp.me/#types
---
--- @since 1.6.18
-setOGType :: MonadWidget m => Text -> m ()
-setOGType a = toWidgetHead $ [hamlet|<meta property="og:type" content=#{a}>|]
-
--- | Add OpenGraph image meta tag to the head of the page
---
--- Best practices:
---
---    * Use custom images for shareable pages, e.g., homepage, articles, etc.
---    * Use your logo or any other branded image for the rest of your pages.
---    * Use images with a 1.91:1 ratio and minimum recommended dimensions of
---      1200x630 for optimal clarity across all devices.
---
--- Source: https://ahrefs.com/blog/open-graph-meta-tags/
---
--- @since 1.6.18
-setOGImage :: MonadWidget m => Text -> m ()
-setOGImage a = toWidgetHead $ [hamlet|<meta property="og:image" content=#{a}>|]
-
 -- | Link to the specified local stylesheet.
 addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
 addStylesheet = flip addStylesheetAttrs []
@@ -305,7 +184,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 +192,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 +210,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 +218,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
@@ -389,10 +268,45 @@ ihamletToHtml ih = do
     return $ ih (toHtml . mrender) urender
 
 tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
-tell = liftWidget . tellWidget
+tell w = liftWidgetT $ WidgetT $ const $ return ((), w)
 
 toUnique :: x -> UniqueList x
 toUnique = UniqueList . (:)
 
-handlerToWidget :: HandlerFor site a -> WidgetFor site a
+handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a
-handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler
+handlerToWidget (HandlerT f) = WidgetT $ liftM (, mempty) . f
+
+widgetToParentWidget :: MonadIO m
+                     => WidgetT child IO a
+                     -> HandlerT child (HandlerT parent m) (WidgetT parent m a)
+widgetToParentWidget (WidgetT f) = HandlerT $ \hd -> do
+    (a, gwd) <- liftIO $ f hd { handlerToParent = const () }
+    return $ WidgetT $ const $ return (a, liftGWD (handlerToParent hd) gwd)
+
+liftGWD :: (child -> parent) -> GWData child -> GWData parent
+liftGWD tp gwd = GWData
+    { gwdBody        = fixBody $ gwdBody gwd
+    , gwdTitle       = gwdTitle gwd
+    , gwdScripts     = fixUnique fixScript $ gwdScripts gwd
+    , gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd
+    , gwdCss         = fixCss <$> gwdCss gwd
+    , gwdJavascript  = fixJS <$> gwdJavascript gwd
+    , gwdHead        = fixHead $ gwdHead gwd
+    }
+  where
+    fixRender f route = f (tp route)
+
+    fixBody (Body h) = Body $ h . fixRender
+    fixHead (Head h) = Head $ h . fixRender
+
+    fixUnique go (UniqueList f) = UniqueList (map go (f []) ++)
+
+    fixScript (Script loc attrs) = Script (fixLoc loc) attrs
+    fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs
+
+    fixLoc (Local url) = Local $ tp url
+    fixLoc (Remote t) = Remote t
+
+    fixCss f = f . fixRender
+
+    fixJS f = f . fixRender

yesod-core/Yesod/Routes/Parse.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE PatternGuards #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
 module Yesod.Routes.Parse
@@ -11,7 +12,6 @@ module Yesod.Routes.Parse
     , TypeTree (..)
     , dropBracket
     , nameToType
-    , isTvar
     ) where
 
 import Language.Haskell.TH.Syntax
@@ -36,15 +36,9 @@ parseRoutes = QuasiQuoter { quoteExp = x }
             [] -> lift res
             z -> error $ unlines $ "Overlapping routes: " : map show z
 
--- | Same as 'parseRoutes', but uses an external file instead of quasiquotation.
---
--- The recommended file extension is @.yesodroutes@.
 parseRoutesFile :: FilePath -> Q Exp
 parseRoutesFile = parseRoutesFileWith parseRoutes
 
--- | Same as 'parseRoutesNoCheck', but uses an external file instead of quasiquotation.
---
--- The recommended file extension is @.yesodroutes@.
 parseRoutesFileNoCheck :: FilePath -> Q Exp
 parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck
 
@@ -71,7 +65,7 @@ parseRoutesNoCheck = QuasiQuoter
 -- invalid input.
 resourcesFromString :: String -> [ResourceTree String]
 resourcesFromString =
-    fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r')
+    fst . parse 0 . filter (not . all (== ' ')) . lines . filter (/= '\r')
   where
     parse _ [] = ([], [])
     parse indent (thisLine:otherLines)
@@ -265,13 +259,8 @@ ttToType (TTApp x y) = ttToType x `AppT` ttToType y
 ttToType (TTList t) = ListT `AppT` ttToType t
 
 nameToType :: String -> Type
-nameToType t = if isTvar t
+nameToType t@(h:_) | isLower h = VarT $ mkName t
-               then VarT $ mkName t
+nameToType t = ConT $ mkName t
-               else ConT $ mkName t
-
-isTvar :: String -> Bool
-isTvar (h:_) = isLower h
-isTvar _     = False
 
 pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
 pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)
@@ -296,12 +285,3 @@ dropBracket str@('{':x) = case break (== '}') x of
     _ -> error $ "Unclosed bracket ('{'): " ++ str
 dropBracket x = x
 
--- | If this line ends with a backslash, concatenate it together with the next line.
---
--- @since 1.6.8
-lineContinuations :: String -> [String] -> [String]
-lineContinuations this [] = [this]
-lineContinuations this below@(next:rest) = case unsnoc this of
-    Just (this', '\\') -> (this'++next):rest
-    _ -> this:below
-  where unsnoc s = if null s then Nothing else Just (init s, last s)

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

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

yesod-core/Yesod/Routes/TH/ParseRoute.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Yesod.Routes.TH.ParseRoute
     ( -- ** ParseRoute
       mkParseRouteInstance
+    , mkParseRouteInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -10,8 +12,11 @@ import Data.Text (Text)
 import Yesod.Routes.Class
 import Yesod.Routes.TH.Dispatch
 
-mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
-mkParseRouteInstance cxt typ ress = do
+mkParseRouteInstance = mkParseRouteInstance' []
+
+mkParseRouteInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkParseRouteInstance' cxt typ ress = do
     cls <- mkDispatchClause
         MkDispatchSettings
             { mdsRunHandler = [|\_ _ x _ -> x|]
@@ -44,4 +49,8 @@ mkParseRouteInstance cxt typ ress = do
     fixDispatch x = x
 
 instanceD :: Cxt -> Type -> [Dec] -> Dec
+#if MIN_VERSION_template_haskell(2,11,0)
 instanceD = InstanceD Nothing
+#else
+instanceD = InstanceD
+#endif

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

@@ -1,93 +1,40 @@
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TemplateHaskell, CPP #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
-
 module Yesod.Routes.TH.RenderRoute
     ( -- ** RenderRoute
       mkRenderRouteInstance
-    , mkRenderRouteInstanceOpts
+    , mkRenderRouteInstance'
     , mkRouteCons
-    , mkRouteConsOpts
     , mkRenderRouteClauses
-
-    , RouteOpts
-    , defaultOpts
-    , setEqDerived
-    , setShowDerived
-    , setReadDerived
     ) where
 
 import Yesod.Routes.TH.Types
+#if MIN_VERSION_template_haskell(2,11,0)
 import Language.Haskell.TH (conT)
+#endif
 import Language.Haskell.TH.Syntax
+#if MIN_VERSION_template_haskell(2,11,0)
 import Data.Bits (xor)
+#endif
 import Data.Maybe (maybeToList)
 import Control.Monad (replicateM)
 import Data.Text (pack)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Yesod.Routes.Class
-
+#if __GLASGOW_HASKELL__ < 710
--- | General opts data type for generating yesod.
+import Control.Applicative ((<$>))
---
+import Data.Monoid (mconcat)
--- Contains options for what instances are derived for the route. Use the setting
+#endif
--- functions on `defaultOpts` to set specific fields.
---
--- @since 1.6.25.0
-data RouteOpts = MkRouteOpts
-    { roDerivedEq   :: Bool
-    , roDerivedShow :: Bool
-    , roDerivedRead :: Bool
-    }
-
--- | Default options for generating routes.
---
--- Defaults to all instances derived.
---
--- @since 1.6.25.0
-defaultOpts :: RouteOpts
-defaultOpts = MkRouteOpts True True True
-
--- |
---
--- @since 1.6.25.0
-setEqDerived :: Bool -> RouteOpts -> RouteOpts
-setEqDerived b rdo = rdo { roDerivedEq = b }
-
--- |
---
--- @since 1.6.25.0
-setShowDerived :: Bool -> RouteOpts -> RouteOpts
-setShowDerived b rdo = rdo { roDerivedShow = b }
-
--- |
---
--- @since 1.6.25.0
-setReadDerived :: Bool -> RouteOpts -> RouteOpts
-setReadDerived b rdo = rdo { roDerivedRead = b }
-
--- |
---
--- @since 1.6.25.0
-instanceNamesFromOpts :: RouteOpts -> [Name]
-instanceNamesFromOpts (MkRouteOpts eq shw rd) = prependIf eq ''Eq $ prependIf shw ''Show $ prependIf rd ''Read []
-    where prependIf b = if b then (:) else const id
 
 -- | Generate the constructors of a route data type.
 mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])
-mkRouteCons = mkRouteConsOpts defaultOpts
+mkRouteCons rttypes =
-
--- | Generate the constructors of a route data type, with custom opts.
---
--- @since 1.6.25.0
-mkRouteConsOpts :: RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])
-mkRouteConsOpts opts rttypes =
     mconcat <$> mapM mkRouteCon rttypes
   where
     mkRouteCon (ResourceLeaf res) =
         return ([con], [])
       where
         con = NormalC (mkName $ resourceName res)
-            $ map (notStrict,)
+            $ map (\x -> (notStrict, x))
             $ concat [singles, multi, sub]
         singles = concatMap toSingle $ resourcePieces res
         toSingle Static{} = []
@@ -101,17 +48,18 @@ mkRouteConsOpts opts rttypes =
                 _ -> []
 
     mkRouteCon (ResourceParent name _check pieces children) = do
-        (cons, decs) <- mkRouteConsOpts opts children
+        (cons, decs) <- mkRouteCons children
-        let conts = mapM conT $ instanceNamesFromOpts opts
 #if MIN_VERSION_template_haskell(2,12,0)
-        dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) conts
+        dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq])
+#elif MIN_VERSION_template_haskell(2,11,0)
+        dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]
 #else
-        dec <- DataD [] (mkName name) [] Nothing cons <$> conts
+        let dec = DataD [] (mkName name) [] cons [''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 +78,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 +95,7 @@ mkRenderRouteClauses =
         let cons y ys = InfixE (Just y) colon (Just ys)
         let pieces' = foldr cons (VarE a) piecesSingle
 
-        let body = LamE [TupP [VarP a, VarP b]] (TupE
+        let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)
-#if MIN_VERSION_template_haskell(2,16,0)
-                                                  $ map Just
-#endif
-                                                  [pieces', VarE b]
-                                                ) `AppE` (rr `AppE` VarE child)
 
         return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
 
@@ -163,7 +106,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 +130,11 @@ mkRenderRouteClauses =
                     let cons y ys = InfixE (Just y) colon (Just ys)
                     let pieces = foldr cons (VarE a) piecesSingle
 
-                    return $ LamE [TupP [VarP a, VarP b]] (TupE
+                    return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
-#if MIN_VERSION_template_haskell(2,16,0)
-                                                            $ map Just
-#endif
-                                                            [pieces, VarE b]
-                                                          ) `AppE` (rr `AppE` VarE x)
                 _ -> do
                     colon <- [|(:)|]
                     let cons a b = InfixE (Just a) colon (Just b)
-                    return $ TupE
+                    return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]
-#if MIN_VERSION_template_haskell(2,16,0)
-                      $ map Just
-#endif
-                      [foldr cons piecesMulti piecesSingle, ListE []]
 
         return $ Clause [pat] (NormalB body) []
 
@@ -214,29 +148,25 @@ mkRenderRouteClauses =
 -- This includes both the 'Route' associated type and the
 -- 'renderRoute' method.  This function uses both 'mkRouteCons' and
 -- 'mkRenderRouteClasses'.
-mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
+mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec]
-mkRenderRouteInstance = mkRenderRouteInstanceOpts defaultOpts
+mkRenderRouteInstance = mkRenderRouteInstance' []
 
--- | Generate the 'RenderRoute' instance.
+-- | A more general version of 'mkRenderRouteInstance' which takes an
---
+-- additional context.
--- This includes both the 'Route' associated type and the
+
--- 'renderRoute' method.  This function uses both 'mkRouteCons' and
+mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
--- 'mkRenderRouteClasses'.
+mkRenderRouteInstance' cxt typ ress = do
---
--- @since 1.6.25.0
-mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
-mkRenderRouteInstanceOpts opts cxt typ ress = do
     cls <- mkRenderRouteClauses ress
-    (cons, decs) <- mkRouteConsOpts opts ress
+    (cons, decs) <- mkRouteCons ress
-#if MIN_VERSION_template_haskell(2,15,0)
+#if MIN_VERSION_template_haskell(2,12,0)
-    did <- DataInstD [] Nothing (AppT (ConT ''Route) typ) Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
-    let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
-#elif MIN_VERSION_template_haskell(2,12,0)
     did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
     let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
-#else
+#elif MIN_VERSION_template_haskell(2,11,0)
     did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)
     let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
+#else
+    let did = DataInstD [] ''Route [typ] cons clazzes'
+    let sds = []
 #endif
     return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)
         [ did
@@ -244,21 +174,25 @@ mkRenderRouteInstanceOpts opts cxt typ ress = do
         ]
         : sds ++ decs
   where
+#if MIN_VERSION_template_haskell(2,11,0)
     clazzes standalone = if standalone `xor` null cxt then
           clazzes'
         else
           []
-    clazzes' = instanceNamesFromOpts opts
+#endif
+    clazzes' = [''Show, ''Eq, ''Read]
 
+#if MIN_VERSION_template_haskell(2,11,0)
 notStrict :: Bang
 notStrict = Bang NoSourceUnpackedness NoSourceStrictness
+#else
+notStrict :: Strict
+notStrict = NotStrict
+#endif
 
 instanceD :: Cxt -> Type -> [Dec] -> Dec
+#if MIN_VERSION_template_haskell(2,11,0)
 instanceD = InstanceD Nothing
-
+#else
-conPCompat :: Name -> [Pat] -> Pat
+instanceD = InstanceD
-conPCompat n pats = ConP n
-#if MIN_VERSION_template_haskell(2,18,0)
-                         []
 #endif
-                         pats

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Routes.TH.RouteAttrs
     ( mkRouteAttrsInstance
+    , mkRouteAttrsInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -10,9 +11,15 @@ import Yesod.Routes.Class
 import Language.Haskell.TH.Syntax
 import Data.Set (fromList)
 import Data.Text (pack)
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative ((<$>))
+#endif
 
-mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
-mkRouteAttrsInstance cxt typ ress = do
+mkRouteAttrsInstance = mkRouteAttrsInstance' []
+
+mkRouteAttrsInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkRouteAttrsInstance' cxt typ ress = do
     clauses <- mapM (goTree id) ress
     return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)
         [ FunD 'routeAttrs $ concat clauses
@@ -27,11 +34,7 @@ goTree front (ResourceParent name _check pieces trees) =
     toIgnore = length $ filter isDynamic pieces
     isDynamic Dynamic{} = True
     isDynamic Static{} = False
-    front' = front . ConP (mkName name)
+    front' = front . ConP (mkName name) . ignored
-#if MIN_VERSION_template_haskell(2,18,0)
-                          []
-#endif
-                   . ignored
 
 goRes :: (Pat -> Pat) -> Resource a -> Q Clause
 goRes front Resource {..} =
@@ -43,4 +46,8 @@ goRes front Resource {..} =
     toText s = VarE 'pack `AppE` LitE (StringL s)
 
 instanceD :: Cxt -> Type -> [Dec] -> Dec
+#if MIN_VERSION_template_haskell(2,11,0)
 instanceD = InstanceD Nothing
+#else
+instanceD = InstanceD
+#endif

yesod-core/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 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
@@ -74,7 +90,7 @@ data FlatResource a = FlatResource
     , frPieces :: [Piece a]
     , frDispatch :: Dispatch a
     , frCheck :: Bool
-    } deriving (Show)
+    }
 
 flatten :: [ResourceTree a] -> [FlatResource a]
 flatten =

yesod-core/bench/widget.hs

@@ -5,20 +5,22 @@
 {-# LANGUAGE QuasiQuotes #-}
 module Main where
 
-import Gauge.Main
+import Criterion.Main
 import Text.Hamlet
 import qualified Data.ByteString.Lazy as L
 import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
 import Data.Monoid (mconcat)
 import Text.Blaze.Html5 (table, tr, td)
 import Text.Blaze.Html (toHtml)
+import Yesod.Core.Widget
+import Yesod.Core.Types
 import Data.Int
 
 main :: IO ()
 main = defaultMain
     [ bench "bigTable html" $ nf bigTableHtml bigTableData
     , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData
-    --, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
+    , bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
     , bench "bigTable blaze" $ nf bigTableBlaze bigTableData
     ]
   where
@@ -47,7 +49,6 @@ bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
                 <td>#{show cell}
 |]
 
-    {-
 bigTableWidget :: Show a => [[a]] -> IO Int64
 bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|
 <table>
@@ -61,7 +62,6 @@ bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whaml
   run (WidgetT w) = do
     (_, GWData { gwdBody = Body x }) <- w undefined
     return x
-    -}
 
 bigTableBlaze :: Show a => [[a]] -> Int64
 bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t

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

@@ -1,52 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts  #-}
-module Yesod.Core.Class.Dispatch where
-
-import qualified Network.Wai as W
-import Yesod.Core.Types
-import Yesod.Core.Content (ToTypedContent (..))
-import Yesod.Core.Handler (sendWaiApplication)
-import Yesod.Core.Class.Yesod
-
--- | This class is automatically instantiated when you use the template haskell
--- mkYesod function. You should never need to deal with it directly.
-class Yesod site => YesodDispatch site where
-    yesodDispatch :: YesodRunnerEnv site -> W.Application
-
-class YesodSubDispatch sub master where
-    yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application
-
-instance YesodSubDispatch WaiSubsite master where
-    yesodSubDispatch YesodSubRunnerEnv {..} = app
-      where
-        WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
-
-instance YesodSubDispatch WaiSubsiteWithAuth master where
-  yesodSubDispatch YesodSubRunnerEnv {..} req =
-      ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
-    where
-      route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []
-      WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
-      handlert = sendWaiApplication set
-
-subHelper
-  :: ToTypedContent content
-  => SubHandlerFor child master content
-  -> YesodSubRunnerEnv child master
-  -> Maybe (Route child)
-  -> W.Application
-subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =
-    ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)
-  where
-    handler = fmap toTypedContent $ HandlerFor $ \hd ->
-      let rhe = handlerEnv hd
-          rhe' = rhe
-            { rheRoute = mroute
-            , rheChild = ysreGetSub $ yreSite ysreParentEnv
-            , rheRouteToMaster = ysreToParentRoute
-            }
-       in f hd { handlerEnv = rhe' }

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

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

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

@@ -1,354 +0,0 @@
-{-# LANGUAGE TemplateHaskellQuotes #-}
-{-# 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
-
-import Prelude hiding (exp)
-import Yesod.Core.Handler
-
-import Language.Haskell.TH hiding (cxt, instanceD)
-import Language.Haskell.TH.Syntax
-
-import qualified Network.Wai as W
-
-import Data.ByteString.Lazy.Char8 ()
-import Data.List (foldl')
-import Control.Monad (replicateM, void)
-import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)
-import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
-
-import Yesod.Routes.TH
-import Yesod.Routes.Parse
-import Yesod.Core.Content (ToTypedContent (..))
-import Yesod.Core.Types
-import Yesod.Core.Class.Dispatch
-import Yesod.Core.Internal.Run
-
--- | Generates URL datatype and site function for the given 'Resource's. This
--- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter.
--- Use 'parseRoutes' to create the 'Resource's.
---
--- Contexts and type variables in the name of the datatype are parsed. 
--- For example, a datatype @App a@ with typeclass constraint @MyClass a@ can be written as @\"(MyClass a) => App a\"@.
-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
-
-
-{-# 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. 
--- Instead, they are explicitly provided. 
--- You can write @(MyClass a) => App a@ with @mkYesodWith [[\"MyClass\",\"a\"]] \"App\" [\"a\"] ...@.
-mkYesodWith :: [[String]] -- ^ list of contexts
-            -> String -- ^ name of the argument datatype
-            -> [String] -- ^ list of type variables
-            -> [ResourceTree String]
-            -> 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
-
-
-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
-
-
--- | Parses contexts and type arguments out of name before generating TH.
-mkYesodWithParser :: String                    -- ^ foundation type
-                  -> Bool                      -- ^ is this a subsite
-                  -> (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
-    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
-
-    where
-        parseName = do
-            cxt <- option [] parseContext
-            name' <- parseWord
-            args <- many parseWord
-            spaces
-            eof
-            return ( name', args, cxt)
-
-        parseWord = do
-            spaces
-            many1 alphaNum
-
-        parseContext = try $ do
-            cxts <- parseParen parseContexts
-            spaces
-            _ <- string "=>"
-            return cxts
-
-        parseParen p = do
-            spaces
-            _ <- char '('
-            r <- p
-            spaces
-            _ <- char ')'
-            return r
-
-        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
-
-
--- | 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)
-      $ ConT ''HandlerFor `AppT` site
-    , 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
-               -> Bool                      -- ^ is this a subsite
-               -> (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
-    let appCxt = fmap (\(c:rest) -> 
-            foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
-          ) appCxt'
-    mname <- lookupTypeName namestr
-    arity <- case mname of
-               Just name -> do
-                 info <- reify name
-                 return $
-                   case info of
-                     TyConI dec ->
-                       case dec of
-                         DataD _ _ vs _ _ _ -> length vs
-                         NewtypeD _ _ vs _ _ _ -> length vs
-                         TySynD _ vs _ -> length vs
-                         _ -> 0
-                     _ -> 0
-               _ -> return 0
-    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
-        res = map (fmap (parseType . dropBracket)) resS
-    renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res
-    routeAttrsDec  <- mkRouteAttrsInstance appCxt site res
-    dispatchDec    <- mkDispatchInstance site appCxt f res
-    parseRoute <- mkParseRouteInstance appCxt site res
-    let rname = mkName $ "resources" ++ namestr
-    eres <- lift resS
-    let resourcesDec =
-            [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
-            , FunD rname [Clause [] (NormalB eres) []]
-            ]
-    let dataDec = concat
-            [ [parseRoute]
-            , renderRouteDec
-            , [routeAttrsDec]
-            , resourcesDec
-            , if isSub then [] else masterTypeSyns argvars site
-            ]
-    return (dataDec, dispatchDec)
-
-
-mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
-mkMDS f rh sd = MkDispatchSettings
-    { mdsRunHandler = rh
-    , mdsSubDispatcher = sd
-    , mdsGetPathInfo = [|W.pathInfo|]
-    , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
-    , mdsMethod = [|W.requestMethod|]
-    , mds404 = [|void notFound|]
-    , mds405 = [|void badMethod|]
-    , mdsGetHandler = defaultGetHandler
-    , mdsUnwrapper = f
-    }
-
--- | If the generation of @'YesodDispatch'@ instance require finer
--- control of the types, contexts etc. using this combinator. You will
--- hardly need this generality. However, in certain situations, like
--- when writing library/plugin for yesod, this combinator becomes
--- handy.
-mkDispatchInstance :: Type                      -- ^ The master site type
-                   -> Cxt                       -- ^ Context of the instance
-                   -> (Exp -> Q Exp)            -- ^ Unwrap handler
-                   -> [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
-    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
-    inner <- newName "inner"
-    let innerFun = FunD inner [clause']
-    helper <- newName "helper"
-    let fun = FunD helper
-                [ Clause
-                    []
-                    (NormalB $ VarE inner)
-                    [innerFun]
-                ]
-    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/test/Hierarchy.hs

@@ -113,9 +113,9 @@ do
 --  /#Int TrailingIntR GET
 |]
 
-    rrinst <- mkRenderRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
+    rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
-    rainst <- mkRouteAttrsInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
+    rainst <- mkRouteAttrsInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
-    prinst <- mkParseRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
+    prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
     dispatch <- mkDispatchClause MkDispatchSettings
         { mdsRunHandler = [|runHandler|]
         , mdsSubDispatcher = [|subDispatch|]

yesod-core/test/RouteSpec.hs

@@ -17,7 +17,7 @@ import Test.HUnit ((@?=))
 import Data.Text (Text, pack, unpack, singleton)
 import Yesod.Routes.Class hiding (Route)
 import qualified Yesod.Routes.Class as YRC
-import Yesod.Routes.Parse (parseRoutesFile, parseRoutesNoCheck, parseTypeTree, TypeTree (..))
+import Yesod.Routes.Parse (parseRoutesNoCheck, parseTypeTree, TypeTree (..))
 import Yesod.Routes.Overlap (findOverlapNames)
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
@@ -72,9 +72,9 @@ do
             [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True
             ]
         ress = resParent : resLeaves
-    rrinst <- mkRenderRouteInstance [] (ConT ''MyApp) ress
+    rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
-    rainst <- mkRouteAttrsInstance [] (ConT ''MyApp) ress
+    rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress
-    prinst <- mkParseRouteInstance [] (ConT ''MyApp) ress
+    prinst <- mkParseRouteInstance (ConT ''MyApp) ress
     dispatch <- mkDispatchClause MkDispatchSettings
         { mdsRunHandler = [|runHandler|]
         , mdsSubDispatcher = [|subDispatch dispatcher|]
@@ -219,17 +219,11 @@ main = hspec $ do
         it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"]
             @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q')
 
-    describe "route parsing" $ do
+    describe "parsing" $ do
         it "subsites work" $ do
             parseRoute ([pack "subsite", pack "foo"], [(pack "bar", pack "baz")]) @?=
                 Just (SubsiteR $ MySubRoute ([pack "foo"], [(pack "bar", pack "baz")]))
 
-    describe "routing table parsing" $ do
-        it "recognizes trailing backslashes as line continuation directives" $ do
-            let routes :: [ResourceTree String]
-                routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations.yesodroutes")
-            length routes @?= 3
-
     describe "overlap checking" $ do
         it "catches overlapping statics" $ do
             let routes :: [ResourceTree String]

yesod-core/test/YesodCoreTest.hs

@@ -5,27 +5,18 @@ import YesodCoreTest.CleanPath
 import YesodCoreTest.Exceptions
 import YesodCoreTest.Widget
 import YesodCoreTest.Media
-import YesodCoreTest.Meta
 import YesodCoreTest.Links
 import YesodCoreTest.Header
 import YesodCoreTest.NoOverloadedStrings
-import YesodCoreTest.SubSub
 import YesodCoreTest.InternalRequest
 import YesodCoreTest.ErrorHandling
 import YesodCoreTest.Cache
-import YesodCoreTest.ParameterizedSite
-import YesodCoreTest.Breadcrumb
 import qualified YesodCoreTest.WaiSubsite as WaiSubsite
 import qualified YesodCoreTest.Redirect as Redirect
 import qualified YesodCoreTest.JsLoader as JsLoader
 import qualified YesodCoreTest.RequestBodySize as RequestBodySize
 import qualified YesodCoreTest.Json as Json
-
--- Skip on Windows, see https://github.com/yesodweb/yesod/issues/1523#issuecomment-398278450
-#if !WINDOWS
 import qualified YesodCoreTest.RawResponse as RawResponse
-#endif
-
 import qualified YesodCoreTest.Streaming as Streaming
 import qualified YesodCoreTest.Reps as Reps
 import qualified YesodCoreTest.Auth as Auth
@@ -44,19 +35,15 @@ specs = do
       mediaTest
       linksTest
       noOverloadedTest
-      subSubTest
       internalRequestTest
       errorHandlingTest
       cacheTest
-      parameterizedSiteTest
       WaiSubsite.specs
       Redirect.specs
       JsLoader.specs
       RequestBodySize.specs
       Json.specs
-#if !WINDOWS
       RawResponse.specs
-#endif
       Streaming.specs
       Reps.specs
       Auth.specs
@@ -65,5 +52,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
@@ -14,15 +15,17 @@ import Network.Wai
 import Network.Wai.Test
 
 import Yesod.Core
-import UnliftIO.IORef
+import Data.IORef.Lifted
 import Data.Typeable (Typeable)
 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
@@ -43,14 +46,7 @@ getRootR = do
     V2 v2a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
     V2 v2b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
 
-    cacheBySet "3" (V2 3)
+    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b]
-    V2 v3a <- cacheByGet "3" >>= \x ->
-      case x of
-        Just y -> return y
-        Nothing -> error "must be Just"
-    V2 v3b <- cachedBy "3" $ (pure $ V2 4)
-
-    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b]
 
 getKeyR :: Handler RepPlain
 getKeyR = do
@@ -64,15 +60,7 @@ getKeyR = do
     V2 v3a <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
     V2 v3b <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
 
-
+    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b]
-    cacheBySet "4" (V2 4)
-    V2 v4a <- cacheByGet "4" >>= \x ->
-      case x of
-        Just y -> return y
-        Nothing -> error "must be Just"
-    V2 v4b <- cachedBy "4" $ (pure $ V2 5)
-
-    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b, v4a, v4b]
 
 getNestedR :: Handler RepPlain
 getNestedR = getNested cached
@@ -98,12 +86,12 @@ cacheTest =
     it "cached" $ runner $ do
       res <- request defaultRequest
       assertStatus 200 res
-      assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res
+      assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res
 
     it "cachedBy" $ runner $ do
       res <- request defaultRequest { pathInfo = ["key"] }
       assertStatus 200 res
-      assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3, 4, 4 :: Int]) res
+      assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res
 
     it "nested cached" $ runner $ do
       res <- request defaultRequest { pathInfo = ["nested"] }

yesod-core/test/YesodCoreTest/CleanPath.hs

@@ -22,7 +22,7 @@ import qualified Data.Text.Encoding as TE
 import Control.Arrow ((***))
 import Network.HTTP.Types (encodePath)
 import Data.Monoid (mappend)
-import Data.Text.Encoding (encodeUtf8Builder)
+import Blaze.ByteString.Builder.Char.Utf8 (fromText)
 
 data Subsite = Subsite
 
@@ -64,7 +64,7 @@ instance Yesod Y where
         corrected = filter (not . TS.null) s
 
     joinPath Y ar pieces' qs' =
-        encodeUtf8Builder ar `Data.Monoid.mappend` encodePath pieces qs
+        fromText ar `Data.Monoid.mappend` encodePath pieces qs
       where
         pieces = if null pieces' then [""] else pieces'
         qs = map (TE.encodeUtf8 *** go) qs'

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -1,37 +1,24 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-
 module YesodCoreTest.ErrorHandling
     ( errorHandlingTest
     , Widget
     , resourcesApp
     ) where
-
-import  Data.Typeable(cast)
-import qualified System.Mem as Mem
-import qualified Control.Concurrent.Async as Async
-import Control.Concurrent as Conc
 import Yesod.Core
 import Test.Hspec
 import Network.Wai
 import Network.Wai.Test
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Char8 as S8
-import Control.Exception (SomeException, try, AsyncException(..))
+import Control.Exception (SomeException, try)
-import           UnliftIO.Exception(finally)
 import Network.HTTP.Types (Status, mkStatus)
-import Data.ByteString.Builder (Builder, toLazyByteString)
+import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
 import Data.Monoid (mconcat)
 import Data.Text (Text, pack)
 import Control.Monad (forM_)
-import qualified Network.Wai.Handler.Warp as Warp
+import qualified Control.Exception.Lifted as E
-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
 
@@ -51,15 +38,6 @@ mkYesod "App" [parseRoutes|
 /file-bad-name FileBadNameR GET
 
 /good-builder GoodBuilderR GET
-
-/auth-not-accepted AuthNotAcceptedR GET
-/auth-not-adequate AuthNotAdequateR GET
-/args-not-valid ArgsNotValidR POST
-/only-plain-text OnlyPlainTextR GET
-
-/thread-killed ThreadKilledR GET
-/connection-closed-by-peer ConnectionClosedPeerR GET
-/sleep-sec SleepASecR GET
 |]
 
 overrideStatus :: Status
@@ -121,28 +99,11 @@ getFileBadNameR :: Handler TypedContent
 getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing
 
 goodBuilderContent :: Builder
-goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n"
+goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ fromByteString "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
@@ -156,18 +117,6 @@ getErrorR 9 = setUltDest (undefined :: Text)
 getErrorR 10 = setMessage undefined
 getErrorR x = error $ "getErrorR: " ++ show x
 
-getAuthNotAcceptedR :: Handler TypedContent
-getAuthNotAcceptedR = notAuthenticated
-
-getAuthNotAdequateR :: Handler TypedContent
-getAuthNotAdequateR = permissionDenied "That doesn't belong to you. "
-
-postArgsNotValidR :: Handler TypedContent
-postArgsNotValidR = invalidArgs ["Doesn't matter.", "Don't want it."]
-
-getOnlyPlainTextR :: Handler TypedContent
-getOnlyPlainTextR = selectRep $ provideRepType "text/plain" $ return ("Only plain text." :: Text)
-
 errorHandlingTest :: Spec
 errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "says not found" caseNotFound
@@ -181,15 +130,6 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "file with bad name" caseFileBadName
       it "builder includes content-length" caseGoodBuilder
       forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i)
-      it "accept DVI file, invalid args -> 400" caseDviInvalidArgs
-      it "accept audio, not authenticated -> 401" caseAudioNotAuthenticated
-      it "accept CSS, permission denied -> 403" caseCssPermissionDenied
-      it "accept image, non-existent path -> 404" caseImageNotFound
-      it "accept video, bad method -> 405" caseVideoBadMethod
-      it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows
-      it "custom config rethrows an exception" caseCustomExceptionRethrows
-      it "thread killed rethrow" caseThreadKilledRethrow
-      it "can timeout a runner" canTimeoutARunner
 
 runner :: Session a -> IO a
 runner f = toWaiApp App >>= runSession f
@@ -277,100 +217,6 @@ caseGoodBuilder = runner $ do
 caseError :: Int -> IO ()
 caseError i = runner $ do
     res <- request defaultRequest { pathInfo = ["error", pack $ show i] }
-    ReaderT $ \r -> StateT $ \s -> runStateT (runReaderT (assertStatus 500 res) r) s `E.catch` \e -> do
+    assertStatus 500 res `E.catch` \e -> do
         liftIO $ print res
         E.throwIO (e :: E.SomeException)
-
-caseDviInvalidArgs :: IO ()
-caseDviInvalidArgs = runner $ do
-    res <- request defaultRequest
-            { pathInfo = ["args-not-valid"]
-            , requestMethod = "POST"
-            , requestHeaders =
-                ("accept", "application/x-dvi") : requestHeaders defaultRequest
-            }
-    assertStatus 400 res
-
-caseAudioNotAuthenticated :: IO ()
-caseAudioNotAuthenticated = runner $ do
-    res <- request defaultRequest
-            { pathInfo = ["auth-not-accepted"]
-            , requestHeaders =
-                ("accept", "audio/mpeg") : requestHeaders defaultRequest
-            }
-    assertStatus 401 res
-
-caseCssPermissionDenied :: IO ()
-caseCssPermissionDenied = runner $ do
-    res <- request defaultRequest
-            { pathInfo = ["auth-not-adequate"]
-            , requestHeaders =
-                ("accept", "text/css") : requestHeaders defaultRequest
-            }
-    assertStatus 403 res
-
-caseImageNotFound :: IO ()
-caseImageNotFound = runner $ do
-    res <- request defaultRequest
-            { pathInfo = ["not_a_path"]
-            , requestHeaders =
-                ("accept", "image/jpeg") : requestHeaders defaultRequest
-            }
-    assertStatus 404 res
-
-caseVideoBadMethod :: IO ()
-caseVideoBadMethod = runner $ do
-    res <- request defaultRequest
-            { pathInfo = ["good-builder"]
-            , requestMethod = "DELETE"
-            , requestHeaders =
-                ("accept", "video/webm") : requestHeaders defaultRequest
-            }
-    assertStatus 405 res
-
-fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e
-fromExceptionUnwrap se
-  | Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e
-  | Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e
-  | otherwise = E.fromException se
-
-
-caseThreadKilledRethrow :: IO ()
-caseThreadKilledRethrow =
-  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
-                                (Just ThreadKilled) -> True
-                                _ -> False
-  where
-  testcode = runner $ do
-                res <- request defaultRequest { pathInfo = ["thread-killed"] }
-                assertStatus 500 res
-                assertBodyContains "Internal Server Error" res
-
-caseDefaultConnectionCloseRethrows :: IO ()
-caseDefaultConnectionCloseRethrows =
-  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
-                                  Just Warp.ConnectionClosedByPeer -> True
-                                  _ -> False
-
-  where
-  testcode = runner $ do
-      _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] }
-      pure ()
-
-caseCustomExceptionRethrows :: IO ()
-caseCustomExceptionRethrows =
-  shouldThrow testcode $ \case Custom.MkMyException -> True
-  where
-    testcode = customAppRunner $ do
-      _res <- request defaultRequest { pathInfo = ["throw-custom-exception"] }
-      pure ()
-    customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f
-
-
-canTimeoutARunner :: IO ()
-canTimeoutARunner = do
-  res <- timeout 1000 $ runner $ do
-    res <- request defaultRequest { pathInfo = ["sleep-sec"] }
-    assertStatus 200 res -- if 500, it's catching the timeout exception
-    pure () -- it should've timeout by now, either being 500 or Nothing
-  res `shouldBe` Nothing -- make sure that pure statement didn't happen.

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

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

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

yesod-core/test/YesodCoreTest/InternalRequest.hs

@@ -10,11 +10,9 @@ import Data.Map (singleton)
 import Yesod.Core
 import Data.Word (Word64)
 import System.IO.Unsafe (unsafePerformIO)
+import qualified System.Random.MWC as MWC
+import Control.Monad.ST
 import Control.Monad (replicateM)
-import System.Random
-
-gen :: IO Int
-gen = getStdRandom next
 
 randomStringSpecs :: Spec
 randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
@@ -23,19 +21,21 @@ randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
 
 -- NOTE: this testcase may break on other systems/architectures if
 -- mkStdGen is not identical everywhere (is it?).
-_looksRandom :: IO ()
+_looksRandom :: Bool
-_looksRandom = do
+_looksRandom = runST $ do
+    gen <- MWC.create
     s <- randomString 20 gen
-    s `shouldBe` "VH9SkhtptqPs6GqtofVg"
+    return $ s == "VH9SkhtptqPs6GqtofVg"
 
-noRepeat :: Int -> Int -> IO ()
+noRepeat :: Int -> Int -> Bool
-noRepeat len n = do
+noRepeat len n = runST $ do
+    gen <- MWC.create
     ss <- replicateM n $ randomString len gen
-    length (nub ss) `shouldBe` n
+    return $ length (nub ss) == n
 
 
 -- For convenience instead of "(undefined :: StdGen)".
-g :: IO Int
+g :: MWC.GenIO
 g = error "test/YesodCoreTest/InternalRequest.g"
 
 parseWaiRequest' :: Request

yesod-core/test/YesodCoreTest/Json.hs

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

yesod-core/test/YesodCoreTest/Links.hs

@@ -13,7 +13,7 @@ import Yesod.Core
 import Network.Wai
 import Network.Wai.Test
 import Data.Text (Text)
-import Data.ByteString.Builder (toLazyByteString)
+import Blaze.ByteString.Builder (toByteString)
 
 data Y = Y
 mkYesod "Y" [parseRoutes|
@@ -86,7 +86,7 @@ case_blanks = runner $ do
     liftIO $ do
         let go r =
                 let (ps, qs) = renderRoute r
-                 in toLazyByteString $ joinPath Y "" ps qs
+                 in toByteString $ joinPath Y "" ps qs
         (go $ TextR "-") `shouldBe` "/single/--"
         (go $ TextR "") `shouldBe` "/single/-"
         (go $ TextsR ["", "-", "foo", "", "bar"]) `shouldBe` "/multi/-/--/foo/-/bar"

yesod-core/test/YesodCoreTest/Meta.hs

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

yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances, ViewPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!!
 module YesodCoreTest.NoOverloadedStrings
     ( noOverloadedTest
@@ -21,19 +20,19 @@ import qualified Data.ByteString.Lazy.Char8 as L8
 getSubsite :: a -> Subsite
 getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)
 
-getBarR :: MonadHandler m => m T.Text
+getBarR :: Monad m => m T.Text
 getBarR = return $ T.pack "BarR"
 
-getBazR :: (MonadHandler m, Yesod (HandlerSite m)) => m Html
+getBazR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html
-getBazR = liftHandler $ defaultLayout [whamlet|Used Default Layout|]
+getBazR = lift $ defaultLayout [whamlet|Used Default Layout|]
 
-getBinR :: (MonadHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html
+getBinR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html
 getBinR = do
-    routeToParent <- getRouteToParent
+    widget <- widgetToParentWidget [whamlet|
-    liftHandler $ defaultLayout [whamlet|
         <p>Used defaultLayoutT
-        <a href=@{routeToParent BazR}>Baz
+        <a href=@{BazR}>Baz
     |]
+    lift $ defaultLayout widget
 
 getOnePiecesR :: Monad m => Int -> m ()
 getOnePiecesR _ = return ()

yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs

@@ -10,7 +10,7 @@ module YesodCoreTest.NoOverloadedStringsSub where
 import Yesod.Core
 import Yesod.Core.Types
 
-data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master -> Application)
+data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application)
 
 mkYesodSubData "Subsite" [parseRoutes|
 /bar BarR GET
@@ -21,7 +21,7 @@ mkYesodSubData "Subsite" [parseRoutes|
 /has-three-pieces/#Int/#Int/#Int ThreePiecesR GET
 |]
 
-instance Yesod master => YesodSubDispatch Subsite master where
+instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where
     yesodSubDispatch ysre =
         f ysre
       where

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

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

yesod-core/test/YesodCoreTest/Reps.hs

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

yesod-core/test/YesodCoreTest/RequestBodySize.hs

@@ -42,11 +42,11 @@ postPostR = do
     return $ RepPlain $ toContent $ T.concat val
 
 postConsumeR = do
-    body <- runConduit $ rawRequestBody .| consume
+    body <- rawRequestBody $$ consume
     return $ RepPlain $ toContent $ S.concat body
 
 postPartialConsumeR = do
-    body <- runConduit $ rawRequestBody .| isolate 5 .| consume
+    body <- rawRequestBody $$ isolate 5 =$ consume
     return $ RepPlain $ toContent $ S.concat body
 
 postUnusedR = return $ RepPlain ""

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