HostPreference conflict #769

.github/ISSUE_TEMPLATE.md

@@ -1,29 +0,0 @@
-<!---
-
-### Bug Reports
-
-Reporting a bug? If relevant, we recommend including:
-
-* Your OS name and version
-* The versions of tools you're using (e.g. `stack`, `yesod` `ghc`).
-* The versions of dependencies you're using
-
-For your convenience, we recommend pasting this script into bash and uploading the output [as a gist](https://gist.github.com/).
-
-```
-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 yesod && yesod version
-```
-
-* Also, is there anything custom or unusual about your setup? i.e. new or prerelease versions of GHC, stack, etc.
-
-* Finally, if possible, please reproduce the error in a small script, or if necessary create a new Github repo with the smallest possible reproducing case. [Stack's scripting support](https://docs.haskellstack.org/en/stable/GUIDE/#script-interpreter) might be useful for creating your reproduction example.
-
-### Support
-
-Please direct support questions to [Stack Overflow](https://stackoverflow.com/questions/tagged/yesod+haskell) or the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb). If you don't get a response there, or you suspect there may be a bug in Yesod causing your problem, you're welcome to ask here.
--->

.github/PULL_REQUEST_TEMPLATE.md

@@ -1,14 +0,0 @@
-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
-
-After submitting your PR:
-
-- [ ] Update the Changelog.md file with a link to your PR
-- [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts)
-
-<!---Thanks so much for contributing! :)
-
-_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

@@ -2,10 +2,7 @@
 *.o
 *.o_p
 *.hi
-dist/
+dist
-dist-stack/
-stack.yaml.lock
-.stack-work
 *.swp
 client_session_key.aes
 cabal-dev/
@@ -16,14 +13,6 @@ cabal.sandbox.config
 /vendor/
 .shelly/
 tarballs/
-
+*.swp
-# useful when mounting into docker
+dist
-.cabal
+client_session_key.aes
-.ghc
-.stackage
-.bash_history
-
-# OS X
-.DS_Store
-*.yaml.lock
-dist-newstyle/

.travis.yml

@@ -0,0 +1,13 @@
+language: haskell
+
+install:
+    - cabal update
+    - cabal install --force-reinstalls hspec cabal-meta cabal-src alex
+    - cabal-meta install --force-reinstalls
+
+script:
+    - echo Done
+    - cabal-meta install --enable-tests
+    - mega-sdist --test
+    - cabal install hspec cabal-meta cabal-src
+    - cabal-meta install --force-reinstalls

CODE_OF_CONDUCT.md

@@ -1,74 +0,0 @@
-# Contributor Covenant Code of Conduct
-
-## Our Pledge
-
-In the interest of fostering an open and welcoming environment, we as
-contributors and maintainers pledge to making participation in our project and
-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
-
-Examples of behavior that contributes to creating a positive environment
-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
-

CONTRIBUTING.md

@@ -1,95 +0,0 @@
-# Contributing
-
-Thanks for your interest in contributing to Yesod! This file has some tips for developing Yesod and getting a pull request accepted.
-
-## Development
-
-Yesod is a mega-repo that contains many Haskell packages, each in a different directory. All the subprojects can be developed with Stack, using `stack <command> <subproject>`, e.g.
-
-* `stack build yesod-form`
-* `stack test yesod-auth`
-* `stack haddock yesod-websockets`
-
-If you'd like to test your changes in a full-fledged Yesod app, you can use Stack to build against it, e.g.:
-
-```
-packages:
-- '/path/to/this/repo/yesod-auth'
-```
-
-## Coding Guidelines
-
-### Safety
-
-Avoid partial functions. Even if you know the partial function is safe in your instance, partial functions require more reasoning from the programmer and are not resilient to refactoring. For the rare cases where a partial function is appropriate, a custom `error` should be used.
-
-### Style 
-
-Keep coding style consistent with the rest of the file, but don't worry about style too much otherwise. PRs changing code style are viewed skeptically.
-
-### Dependencies
-
-Avoid adding unnecessary dependencies. If a dependency provides only a minor convenience for your implementation, it's probably better to skip it.
-
-If you do add a new dependency, try to support a wide range of versions of it.
-
-### Backwards Compatibility
-
-Backwards incompatible changes are viewed skeptically—best to ask in an issue to see if a particular backwards incompatible change would be approved. If possible keep backwards compatibility by adding new APIs and deprecating old ones.
-
-Keep backwards compatibility with old versions of dependencies when possible.
-
-## PR Guidelines
-
-### PR Scope
-
-As much as possible, keep separate changes in separate PRs.
-
-### Testing
-
-Tests are recommended, but not required.
-
-### Documentation
-
-All public APIs must be documented. Documenting private functions is optional, but may be nice depending on their complexity. Example documentation:
-
-```
--- | Looks up the hidden input named "_token" and adds its value to the params.
---
--- ==== __Examples__
---
--- > request $ do
--- >   addToken_ "#formID"
---
--- @since 1.5.4
-addToken_ :: Query -- ^ CSS selector that resolves to the @<form>@ containing the token.
-		  -> RequestBuilder site ()
-```
-
-Examples are recommended, but not required, in documentation. Marking new APIs with `@since <version number>` is required.
-
-### Versioning
-
-Yesod packages roughly follow the Haskell Package Versioning Policy style of A.B.C.[D] (MAJOR.MAJOR.MINOR.[PATCH])
-
-* A - Used for massive changes in the library. (Example: 1.2.3.4 becomes 2.0.0)
-* B - Used for smaller breaking changes, like removing, renaming, or changing behavior of existing public API. (Example: 1.2.3.4 becomes 1.3.0)
-* C - Used for new public APIs (Example: 1.2.3.4 becomes 1.2.4)
-* D - Used for bug fixes (Example: 1.2.3.4 becomes 1.2.3.5).
-	* D is optional in the version number, so 2.0.0 is a valid version.
-
-Documentation changes don't require a new version.
-
-If you feel there is ambiguity to a change (e.g. fixing a bug in a function, when people may be relying on the old broken behavior), you can ask in an issue or pull request.
-
-Unlike in the Package Versioning Policy, deprecations are not counted as MAJOR changes.
-
-In some cases, dropping compatibility with a major version of a dependency (e.g. changing from transformers >= 0.3 to transformers >= 0.4), is considered a breaking change.
-
-### Changelog
-
-After you submit a PR, update the subproject's Changelog.md file with the new version number and a link to your PR. If your PR does not need to bump the version number, include the change in an "Unreleased" section at the top.
-
-### Releases
-
-Releases should be done as soon as possible after a pull request is merged—don't be shy about reminding us to make a release if we forget.

Dockerfile

@@ -1,36 +0,0 @@
-FROM haskell:7.10
-MAINTAINER Greg Weber
-
-# Intended as a development environment
-#
-#    docker build -t yesod .
-#    docker run --rm -i -t -v `pwd`:/home/haskell yesod /bin/bash
-#    stackage update
-#
-
-RUN apt-get update && apt-get install sudo \
-    # ssl stuff that you may find useful
- && apt-get install -y libssl-dev ca-certificates libcurl4-openssl-dev \
-    # stackage-cli uses git. authbind can be useful for exposing ports
- && apt-get install -y git authbind \
- && apt-get clean
-
-# run as a user named "haskell"
-RUN useradd -m -d /home/haskell -s /bin/bash haskell
-RUN mkdir -p /etc/sudoers.d && echo "haskell ALL=(ALL) NOPASSWD: ALL" > /etc/sudoers.d/haskell && chmod 0440 /etc/sudoers.d/haskell
-ENV HOME /home/haskell
-WORKDIR /home/haskell
-USER haskell
-ENV LANG   C.UTF-8
-ENV LC_ALL C.UTF-8
-
-# install stackage binaries to /opt/stackage
-RUN sudo mkdir -p /opt/stackage/bin
-ENV PATH /opt/stackage/bin:.cabal-sandbox/bin:.cabal/bin:$PATH:./
-RUN sudo chown haskell:haskell /opt/stackage/bin
-RUN cabal update \
- && cabal install stackage-update && stackage-update \
- && cabal install stackage-install \
- && stackage-install stackage-cli stackage-cabal stackage-sandbox stackage-upload \
- && mv /home/haskell/.cabal/bin/* /opt/stackage/bin/ \
- && rm -r /home/haskell/.cabal 

LICENSE

@@ -1,4 +1,4 @@
-Copyright (c) 2012-2017 Michael Snoyman, http://www.yesodweb.com/
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
 
 Permission is hereby granted, free of charge, to any person obtaining
 a copy of this software and associated documentation files (the

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,6 +1,4 @@
-![Tests](https://github.com/yesodweb/yesod/workflows/Tests/badge.svg)
+# Yesod
-
-# Yesod Web Framework
 
 An advanced web framework using the Haskell programming language. Featuring:
 
@@ -12,50 +10,108 @@ 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: http://yesodweb.com/
 
-Learn more about Yesod on [its main website](http://www.yesodweb.com/). If you
+## Install the latests stable Yesod: http://www.yesodweb.com/page/quickstart
-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!
+    cabal update && cabal install yesod
 
-```haskell
+### Create a new project after installing
-{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies #-}
 
-import Yesod
+    yesod init
 
-data App = App -- Put your config, database connection pool, etc. in here.
+Your application is a cabal package and you use `cabal` to install its dependencies.
 
--- Derive routes and instances for App.
+# Installing & isolation
-mkYesod "App" [parseRoutes|
-/ HomeR GET
-|]
 
-instance Yesod App -- Methods in here can be overridden as needed.
+Install conflicts are unfortunately common in Haskell development.
+If you are not using any sandbox tools, you may discover that some of the other haskell installs on your system are broken.
+You can prevent this by using cabal sandbox.
 
--- The handler for the GET request at /, corresponds to HomeR.
+Isolating an entire project is also a great idea, you just need some tools to help that process.
-getHomeR :: Handler Html
+On Linux you can use Docker.
-getHomeR = defaultLayout [whamlet|Hello World!|]
+On any OS you can use a virtual machine. [Vagrant](http://vagrantup.com) is a great tool for that and there is a [Haskell Platform installer](https://bitbucket.org/puffnfresh/vagrant-haskell-heroku) for it.
 
-main :: IO ()
+## Using cabal sandbox
-main = warp 3000 App
-```
 
-To read about each of the concepts in use above (routing, handlers,
+To sandbox a project, type:
-linking, JSON), in detail, visit
-[Basics in the Yesod book](https://www.yesodweb.com/book/basics#basics_routing).
 
-## Hacking on Yesod
+    cabal sandbox init
 
-Yesod consists mostly of four repositories:
+This ensures that future installs will be local to the sandboxed directory.
 
-```bash
-git clone --recurse-submodules http://github.com/yesodweb/shakespeare
-git clone --recurse-submodules http://github.com/yesodweb/persistent
-git clone --recurse-submodules http://github.com/yesodweb/wai
-git clone --recurse-submodules http://github.com/yesodweb/yesod
-```
 
-Each repository can be built with `stack build`.
+## Installing the latest development version from github for use with your application
+
+    cabal update
+    cabal install cabal-meta cabal-src
+
+In your application folder, create a `sources.txt` file with the following contents:
+
+    ./
+    https://github.com/yesodweb/yesod
+    https://github.com/yesodweb/shakespeare
+    https://github.com/yesodweb/persistent
+    https://github.com/yesodweb/wai
+
+`./` means build your app. The yesod repos will be cloned and placed in a `vendor` repo.
+Now run: `cabal-meta install`.
+
+This should work almost all of the time. You can read more on [cabal-meta](https://github.com/yesodweb/cabal-meta)
+If you aren't building from an application, remove the `./` and create a new directory for your sources.txt first.
+
+
+
+## hsenv (Linux and Mac OS X)
+
+[hsenv](https://github.com/tmhedberg/hsenv) also provides a sandbox, but works at the shell level.
+Generally we recommend using cabal sandbox, but hsenv has tools for allowing you to use different versions of GHC, which may be useful for you.
+
+
+
+## Cloning the repos
+
+The above instructions for building the latest should work well.
+But you can clone the repos without the help of cabal-meta:
+
+~~~ { .bash }
+for repo in shakespeare persistent wai yesod; do
+  git clone http://github.com/yesodweb/$repo
+  (
+    cd $repo
+    git submodule update --init
+  )
+done
+~~~~
+
+## Building your changes to Yesod
+
+The traditional Yesod stack requires 4 "mega-repos", each with multiple cabal packages. `./script/install` will run tests against each package and install each package.
+
+### install package in all repos
+
+~~~ { .bash }
+for repo in shakespeare persistent wai yesod; do
+    pushd $repo
+    ./scripts/install
+    popd
+done
+~~~
+
+### Clean build (sometimes necessary)
+
+~~~ { .bash }
+./scripts/install --clean
+~~~
+
+### Building individual packages
+
+~~~ { .bash }
+# move to the individual package you are working on
+cd shakespeare-text
+
+# build and test the individual package
+cabal configure -ftest --enable-tests
+cabal build
+cabal test
+~~~

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)

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/config/secrets.yaml

@@ -1,2 +0,0 @@
-accessKey: <your access key>
-secretKey: <your secret key>

demo/auth/email_auth_ses_mailer.hs

@@ -1,205 +0,0 @@
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GADTs                      #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE QuasiQuotes                #-}
-{-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE OverloadedStrings          #-}
-import           Control.Monad (join)
-import           Control.Monad.Logger (runNoLoggingT)
-import           Data.Maybe (isJust)
-import           Data.Yaml
-import           Data.Text (Text)
-import qualified Data.Text.Encoding as TE
-import qualified Data.Text.Lazy.Encoding as LTE
-import           Database.Persist.Sqlite
-import           Database.Persist.TH
-import           Network.Mail.Mime
-import           Text.Blaze.Html.Renderer.Utf8 (renderHtml)
-import           Text.Shakespeare.Text (stext)
-import           Yesod
-import           Yesod.Auth
-import           Yesod.Auth.Email
-import           Network.Mail.Mime.SES
-import           Data.ByteString.Char8
-import           Control.Monad (mzero)
-import           Network.HTTP.Client.Conduit (Manager, newManager, HasHttpManager (getHttpManager))
-import           System.Exit (exitWith, ExitCode( ExitFailure ))
-
-share [mkPersist sqlSettings { mpsGeneric = False }, mkMigrate "migrateAll"] [persistLowerCase|
-User
-    email Text
-    password Text Maybe -- Password may not be set yet
-    verkey Text Maybe -- Used for resetting passwords
-    verified Bool
-    UniqueUser email
-|]
-
-data App = App
-    { sqlBackend     :: SqlBackend
-    , appHttpManager :: Manager
-    }
-
-instance HasHttpManager App where
-  getHttpManager = appHttpManager
-
-mkYesod "App" [parseRoutes|
-/ HomeR GET
-/auth AuthR Auth getAuth
-|]
-
-instance Yesod App where
-    -- Emails will include links, so be sure to include an approot so that
-    -- the links are valid!
-    approot = ApprootStatic "http://localhost:3000"
-
-instance RenderMessage App FormMessage where
-    renderMessage _ _ = defaultFormMessage
-
--- Set up Persistent
-instance YesodPersist App where
-    type YesodPersistBackend App = SqlBackend
-    runDB f = do
-        App conn _ <- getYesod
-        runSqlConn f conn
-
-instance YesodAuth App where
-    type AuthId App = UserId
-
-    loginDest _ = HomeR
-    logoutDest _ = HomeR
-    authPlugins _ = [authEmail]
-
-    -- Need to find the UserId for the given email address.
-    getAuthId creds = runDB $ do
-        x <- insertBy $ User (credsIdent creds) Nothing Nothing False
-        return $ Just $
-            case x of
-                Left (Entity userid _) -> userid -- newly added user
-                Right userid -> userid -- existing user
-
-    authHttpManager = error "Email doesn't need an HTTP manager"
-
-instance YesodAuthPersist App
-
--- Here's all of the email-specific code
-
-data SesKeys = SesKeys { accessKey :: !Text, secretKey :: !Text }
-
-instance FromJSON SesKeys where
-  parseJSON (Object v) =
-    SesKeys <$> v .: "accessKey"
-            <*> v .: "secretKey"
-  parseJSON _ = mzero
-
-instance YesodAuthEmail App where
-    type AuthEmailId App = UserId
-
-    afterPasswordRoute _ = HomeR
-
-    addUnverified email verkey =
-        runDB $ insert $ User email Nothing (Just verkey) False
-
-    -- Send the verification email with your SES credentials located in config/secrets.yaml
-    -- NOTE: The email address you're sending from will have to be verified on SES
-    sendVerifyEmail email _ verurl = do
-        h <- getYesod
-        sesCreds <- liftIO $ getSESCredentials
-
-        liftIO $ renderSendMailSES (getHttpManager h) sesCreds (emptyMail $ Address Nothing "noreply@example.com")
-            { mailTo = [Address Nothing email]
-            , mailHeaders =
-                [ ("Subject", "Verify your email address")
-                ]
-            , mailParts = [[textPart, htmlPart]]
-            }
-      where
-        getSESCredentials :: IO SES
-        getSESCredentials = do
-            key <- getsesAccessKey
-            return SES {
-                sesTo = [(TE.encodeUtf8 email)],
-                sesFrom = "noreply@example.com",
-                sesAccessKey =  TE.encodeUtf8 $ accessKey key,
-                sesSecretKey =  TE.encodeUtf8 $ secretKey key,
-                sesRegion = usWest2 }
-        getsesAccessKey :: IO SesKeys
-        getsesAccessKey = do
-            ymlConfig <- Data.ByteString.Char8.readFile "config/secrets.yaml"
-
-            case decode ymlConfig of
-                Nothing -> do Data.ByteString.Char8.putStrLn "Error while parsing secrets.yaml"; System.Exit.exitWith (ExitFailure 1)
-                Just c -> return c
-
-        textPart = Part
-            { partType = "text/plain; charset=utf-8"
-            , partEncoding = None
-            , partFilename = Nothing
-            , partContent = LTE.encodeUtf8 $
-                [stext|
-                    Please confirm your email address by clicking on the link below.
-
-                    #{verurl}
-
-                    Thank you
-                |]
-            , partHeaders = []
-            }
-        htmlPart = Part
-            { partType = "text/html; charset=utf-8"
-            , partEncoding = None
-            , partFilename = Nothing
-            , partContent = renderHtml
-                [shamlet|
-                    <p>Please confirm your email address by clicking on the link below.
-                    <p>
-                        <a href=#{verurl}>#{verurl}
-                    <p>Thank you
-                |]
-            , partHeaders = []
-            }
-    getVerifyKey = runDB . fmap (join . fmap userVerkey) . get
-    setVerifyKey uid key = runDB $ update uid [UserVerkey =. Just key]
-    verifyAccount uid = runDB $ do
-        mu <- get uid
-        case mu of
-            Nothing -> return Nothing
-            Just u -> do
-                update uid [UserVerified =. True]
-                return $ Just uid
-    getPassword = runDB . fmap (join . fmap userPassword) . get
-    setPassword uid pass = runDB $ update uid [UserPassword =. Just pass]
-    getEmailCreds email = runDB $ do
-        mu <- getBy $ UniqueUser email
-        case mu of
-            Nothing -> return Nothing
-            Just (Entity uid u) -> return $ Just EmailCreds
-                { emailCredsId = uid
-                , emailCredsAuthId = Just uid
-                , emailCredsStatus = isJust $ userPassword u
-                , emailCredsVerkey = userVerkey u
-                , emailCredsEmail = email
-                }
-    getEmail = runDB . fmap (fmap userEmail) . get
-
-getHomeR :: Handler Html
-getHomeR = do
-    maid <- maybeAuthId
-    defaultLayout
-        [whamlet|
-            <p>Your current auth ID: #{show maid}
-            $maybe _ <- maid
-                <p>
-                    <a href=@{AuthR LogoutR}>Logout
-            $nothing
-                <p>
-                    <a href=@{AuthR LoginR}>Go to the login page
-        |]
-
-main :: IO ()
-main = runNoLoggingT $ withSqliteConn "email.db3" $ \conn -> liftIO $ do
-    runSqlConn (runMigration migrateAll) conn
-    httpManager <- newManager
-    warp 3000 $ App conn httpManager

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-routes
+./yesod-core
+./yesod-static
+./yesod-persistent
+./yesod-newsfeed
+./yesod-form
+./yesod-auth
+./yesod-sitemap
+./yesod-test
+./yesod-bin
+./yesod
+./yesod-eventsource
+./yesod-websockets

stack.yaml

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

stack.yaml.lock

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

yesod-auth-oauth/ChangeLog.md

@@ -1,33 +0,0 @@
-# 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
-
-## 1.4.1
-
-* change OAuth Twitter ID, screen_name → user_id [#1168](https://github.com/yesodweb/yesod/pull/1168)
-
-## 1.4.0.2
-
-* Compile with GHC 7.10

yesod-auth-oauth/README.md

@@ -1,3 +0,0 @@
-## yesod-auth-oauth
-
-Oauth Authentication for Yesod.

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

@@ -1,22 +1,16 @@
-{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 module Yesod.Auth.OAuth
     ( authOAuth
     , oauthUrl
     , authTwitter
-    , authTwitterUsingUserId
     , twitterUrl
     , authTumblr
     , tumblrUrl
     , module Web.Authenticate.OAuth
     ) where
-import           Control.Applicative      as A ((<$>), (<*>))
+import           Control.Applicative      ((<$>), (<*>))
 import           Control.Arrow            ((***))
-import           UnliftIO.Exception
+import           Control.Exception.Lifted
 import           Control.Monad.IO.Class
 import           Data.ByteString          (ByteString)
 import           Data.Maybe
@@ -24,6 +18,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 +26,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
@@ -77,14 +64,14 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
                                 ]
           else do
             (verifier, oaTok) <-
-                runInputGet $ (,) A.<$> ireq textField "oauth_verifier"
+                runInputGet $ (,) <$> ireq textField "oauth_verifier"
-                                  A.<*> ireq textField "oauth_token"
+                                  <*> ireq textField "oauth_token"
             return $ Credential [ ("oauth_verifier", encodeUtf8 verifier)
                                 , ("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
@@ -94,19 +81,18 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
         let oaUrl = render $ tm $ oauthUrl name
         [whamlet| <a href=#{oaUrl}>Login via #{name} |]
 
-mkExtractCreds :: Text -> String -> Credential -> IO (Creds m)
+mkExtractCreds :: YesodAuth m => Text -> String -> Credential -> IO (Creds m)
 mkExtractCreds name idName (Credential dic) = do
   let mcrId = decodeUtf8With lenientDecode <$> lookup (encodeUtf8 $ T.pack idName) dic
   case mcrId of
     Just crId -> return $ Creds name crId $ map (bsToText *** bsToText) dic
     Nothing -> throwIO $ CredentialError ("key not found: " ++ idName) (Credential dic)
 
-authTwitter' :: YesodAuth m
+authTwitter :: YesodAuth m
-             => ByteString -- ^ Consumer Key
+            => ByteString -- ^ Consumer Key
-             -> ByteString -- ^ Consumer Secret
+            -> ByteString -- ^ Consumer Secret
-             -> String
+            -> AuthPlugin m
-             -> AuthPlugin m
+authTwitter key secret = authOAuth
-authTwitter' key secret idName = authOAuth
                 (newOAuth { oauthServerName      = "twitter"
                           , oauthRequestUri      = "https://api.twitter.com/oauth/request_token"
                           , oauthAccessTokenUri  = "https://api.twitter.com/oauth/access_token"
@@ -116,26 +102,7 @@ authTwitter' key secret idName = authOAuth
                           , oauthConsumerSecret  = secret
                           , oauthVersion         = OAuth10a
                           })
-                (mkExtractCreds "twitter" idName)
+                (mkExtractCreds "twitter" "screen_name")
-
--- | This plugin uses Twitter's /screen_name/ as ID, which shouldn't be used for authentication because it is mutable.
-authTwitter :: YesodAuth m
-            => ByteString -- ^ Consumer Key
-            -> ByteString -- ^ Consumer Secret
-            -> AuthPlugin m
-authTwitter key secret = authTwitter' key secret "screen_name"
-{-# DEPRECATED authTwitter "Use authTwitterUsingUserId instead" #-}
-
--- | Twitter plugin which uses Twitter's /user_id/ as ID.
---
--- For more information, see: https://github.com/yesodweb/yesod/pull/1168
---
--- @since 1.4.1
-authTwitterUsingUserId :: YesodAuth m
-                  => ByteString -- ^ Consumer Key
-                  -> ByteString -- ^ Consumer Secret
-                  -> AuthPlugin m
-authTwitterUsingUserId key secret = authTwitter' key secret "user_id"
 
 twitterUrl :: AuthRoute
 twitterUrl = oauthUrl "twitter"

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.3.0
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
@@ -8,21 +7,27 @@ maintainer:      Michael Litchard
 synopsis:        OAuth Authentication for Yesod.
 category:        Web, Yesod
 stability:       Stable
+cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
-description:     API docs and the README are available at <http://www.stackage.org/package/yesod-auth-oauth>
+description:     Oauth Authentication for Yesod.
-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.6
                    , bytestring              >= 0.9.1.4
+                   , yesod-core              >= 1.2       && < 1.3
+                   , yesod-auth              >= 1.3       && < 1.4
                    , text                    >= 0.7
-                   , unliftio
+                   , yesod-form              >= 1.3       && < 1.4
-                   , yesod-auth              >= 1.6       && < 1.7
+                   , transformers            >= 0.2.2     && < 0.5
-                   , 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,225 +0,0 @@
-# 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)
-
-## 1.4.20
-
-* Extend `YesodAuthEmail` to support extensible password hashing via
-  `hashAndSaltPassword` and `verifyPassword` functions
-
-## 1.4.19
-
-* Adjust English localization to distinguish between "log in" (verb) and "login" (noun)
-
-## 1.4.18
-
-* Expose Yesod.Auth.Util.PasswordStore
-
-## 1.4.17.3
-
-* Some translation fixes
-
-## 1.4.17.2
-
-* Move to cryptonite from cryptohash
-
-## 1.4.17.1
-
-* Some translation fixes
-
-## 1.4.17
-
-* Add Show instance for user credentials `Creds`
-* Export pid type for identifying plugin
-* Fix warnings
-* Allow for a custom Email Login DOM with `emailLoginHandler`
-
-## 1.4.16
-
-* Fix email provider [#1330](https://github.com/yesodweb/yesod/issues/1330)
-* Document JSON endpoints of Yesod.Auth.Email
-
-## 1.4.15
-
-* Add JSON endpoints to Yesod.Auth.Email module
-* Export croatianMessage from Message module
-* Minor Haddock rendering fixes at Auth.Email module
-
-## 1.4.14
-
-* Remove Google OpenID link [#1309](https://github.com/yesodweb/yesod/pull/1309)
-* Add CSRF Security check in `registerHelperFunction` [#1302](https://github.com/yesodweb/yesod/pull/1302)
-
-## 1.4.13.5
-
-* Translation fix
-
-## 1.4.13.4
-
-* Improved translations
-* peristent 2.6
-
-## 1.4.13.3
-
-* Doc update (and a warning)
-
-## 1.4.13.1
-
-* Add CSRF token to login form from `Yesod.Auth.Dummy` [#1205](https://github.com/yesodweb/yesod/pull/1205)
-
-## 1.4.13
-
-* Add a CSRF token to the login form from `Yesod.Auth.Hardcoded`, making it compatible with the CSRF middleware [#1161](https://github.com/yesodweb/yesod/pull/1161)
-* Multiple session messages. [#1187](https://github.com/yesodweb/yesod/pull/1187)
-
-## 1.4.12
-
-* Deprecated Yesod.Auth.GoogleEmail
-
-## 1.4.11
-
-Add Yesod.Auth.Hardcoded
-
-## 1.4.9
-
-* Expose defaultLoginHandler
-
-## 1.4.8
-
-* GoogleEmail2: proper error message when permission denied
-
-## 1.4.7
-
-* add a runHttpRequest function for handling HTTP errors
-
-## 1.4.6
-
-* Use nonce package to generate verification keys and CSRF tokens [#1011](https://github.com/yesodweb/yesod/pull/1011)
-
-## 1.4.5
-
-* Adds export of email verify route [#980](https://github.com/yesodweb/yesod/pull/980)
-
-## 1.4.4
-
-* Add AuthenticationResult and authenticate function [#959](https://github.com/yesodweb/yesod/pull/959)
-
-## 1.4.3
-
-* Added means to fetch user's Google profile [#936](https://github.com/yesodweb/yesod/pull/936)
-
-## 1.4.2
-
-* Perform `onLogout` before session cleaning [#923](https://github.com/yesodweb/yesod/pull/923)
-
-## 1.4.1.3
-
-[Updated french translation of Yesod.Auth.Message. #904](https://github.com/yesodweb/yesod/pull/904)
-
-## 1.4.1
-
-Dutch translation added.

yesod-auth/README.md

@@ -1,12 +0,0 @@
-## yesod-auth
-
-This package provides a pluggable mechanism for allowing users to authenticate
-with your site. It comes with a number of common plugins, such as OpenID,
-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/Yesod/Auth.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
@@ -8,7 +7,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Yesod.Auth
     ( -- * Subsite
@@ -18,7 +17,8 @@ module Yesod.Auth
     , AuthPlugin (..)
     , getAuth
     , YesodAuth (..)
-    , YesodAuthPersist (..)
+    , YesodAuthPersist
+    , AuthEntity
       -- * Plugin interface
     , Creds (..)
     , setCreds
@@ -27,18 +27,13 @@ module Yesod.Auth
     , loginErrorMessage
     , loginErrorMessageI
       -- * User functions
-    , AuthenticationResult (..)
     , defaultMaybeAuthId
-    , defaultLoginHandler
-    , maybeAuthPair
     , maybeAuth
     , requireAuthId
-    , requireAuthPair
     , requireAuth
       -- * Exception
     , AuthException (..)
       -- * Helper
-    , MonadAuthHandler
     , AuthHandler
       -- * Internal
     , credsKey
@@ -49,19 +44,19 @@ module Yesod.Auth
 
 import Control.Monad                 (when)
 import Control.Monad.Trans.Maybe
-import UnliftIO                      (withRunInIO, MonadUnliftIO)
 
 import Yesod.Auth.Routes
+import Data.Aeson
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
 import           Data.Text (Text)
 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.Conduit (Manager)
-import Network.HTTP.Client.TLS (getGlobalManager)
 
 import qualified Network.Wai as W
+import Text.Hamlet (shamlet)
 
 import Yesod.Core
 import Yesod.Persist
@@ -70,31 +65,22 @@ import qualified Yesod.Auth.Message as Msg
 import Yesod.Form (FormMessage)
 import Data.Typeable (Typeable)
 import Control.Exception (Exception)
-import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
+import Network.HTTP.Types          (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
-data AuthenticationResult master
-    = Authenticated (AuthId master) -- ^ Authenticated successfully
-    | UserError AuthMessage         -- ^ Invalid credentials provided by user
-    | ServerError Text              -- ^ Some other error
-
 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
@@ -105,14 +91,14 @@ data Creds master = Creds
     { credsPlugin :: Text -- ^ How the user was authenticated
     , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.
     , credsExtra :: [(Text, Text)]
-    } deriving (Show)
+    }
 
 class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where
     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.
@@ -122,53 +108,20 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- destination exists.
     logoutDest :: master -> Route master
 
-    -- | Perform authentication based on the given credentials.
-    --
-    -- Default implementation is in terms of @'getAuthId'@
-    --
-    -- @since: 1.4.4
-    authenticate :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (AuthenticationResult master)
-    authenticate creds = do
-        muid <- getAuthId creds
-
-        return $ maybe (UserError Msg.InvalidLogin) Authenticated muid
-
     -- | Determine the ID associated with the set of credentials.
-    --
+    getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master))
-    -- Default implementation is in terms of @'authenticate'@
-    --
-    getAuthId :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (Maybe (AuthId master))
-    getAuthId creds = do
-        auth <- authenticate creds
-
-        return $ case auth of
-            Authenticated auid -> Just auid
-            _ -> Nothing
 
     -- | Which authentication backends to use.
     authPlugins :: master -> [AuthPlugin master]
 
     -- | What to show on the login page.
-    --
-    -- By default this calls 'defaultLoginHandler', which concatenates
-    -- plugin widgets and wraps the result in 'authLayout'. Override if
-    -- you need fancy widget containers, additional functionality, or an
-    -- entirely custom page.  For example, in some applications you may
-    -- want to prevent the login page being displayed for a user who is
-    -- already logged in, even if the URL is visited explicitly; this can
-    -- be done by overriding 'loginHandler' in your instance declaration
-    -- with something like:
-    --
-    -- > instance YesodAuth App where
-    -- >     ...
-    -- >     loginHandler = do
-    -- >         ma <- lift maybeAuthId
-    -- >         when (isJust ma) $
-    -- >             lift $ redirect HomeR   -- or any other Handler code you want
-    -- >         defaultLoginHandler
-    --
     loginHandler :: AuthHandler master Html
-    loginHandler = defaultLoginHandler
+    loginHandler = do
+        tp <- getRouteToParent
+        lift $ authLayout $ do
+            setTitleI Msg.LoginTitle
+            master <- getYesod
+            mapM_ (flip apLogin tp) (authPlugins master)
 
     -- | Used for i18n of messages provided by this package.
     renderAuthMessage :: master
@@ -182,27 +135,19 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     redirectToReferer :: master -> Bool
     redirectToReferer _ = False
 
-    -- | When being redirected to the login page should the current page
-    -- be set to redirect back to. Default is 'True'.
-    --
-    -- @since 1.4.21
-    redirectToCurrent :: master -> Bool
-    redirectToCurrent _ = True
-
     -- | Return an HTTP connection manager that is stored in the foundation
     -- 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@.
+    -- @setMessageI NowLoggedIn@.
-    onLogin :: (MonadHandler m, master ~ HandlerSite m) => m ()
+    onLogin :: HandlerT master IO ()
-    onLogin = addMessageI "success" Msg.NowLoggedIn
+    onLogin = setMessageI 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,154 +158,129 @@ 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))
+        :: ( YesodAuth master
-        => m (Maybe (AuthId master))
+           , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
+           , b ~ YesodPersistBackend master
+           , Key val ~ AuthId master
+           , PersistStore (b (HandlerT master IO))
+           , PersistEntity val
+           , YesodPersist master
+           , Typeable val
+           )
+        => 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@.
+    -- @setMessage@ 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
+        setMessage $ toHtml msg
         fmap asHtml $ redirect dest
 
-    -- | runHttpRequest gives you a chance to handle an HttpException and retry
-    --  The default behavior is to simply execute the request which will throw an exception on failure
-    --
-    --  The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request.
-    --  This is an experimental API that is not broadly used throughout the yesod-auth code base
-    runHttpRequest
-      :: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m)
-      => Request
-      -> (Response BodyReader -> m a)
-      -> m a
-    runHttpRequest req inner = do
-      man <- authHttpManager
-      withRunInIO $ \run -> withResponse req man $ run . inner
-
-    {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins #-}
-
-{-# 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"
 
 -- | Retrieves user credentials from the session, if user is authenticated.
 --
 -- This function does /not/ confirm that the credentials are valid, see
--- 'maybeAuthIdRaw' for more information. The first call in a request
+-- 'maybeAuthIdRaw' for more information.
--- 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))
+          :: ( YesodAuth master
-    => m (Maybe (AuthId master))
+             , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
-defaultMaybeAuthId = runMaybeT $ do
+             , b ~ YesodPersistBackend master
-    s   <- MaybeT $ lookupSession credsKey
+             , Key val ~ AuthId master
-    aid <- MaybeT $ return $ fromPathPiece s
+             , PersistStore (b (HandlerT master IO))
-    _   <- MaybeT $ cachedAuth aid
+             , PersistEntity val
-    return aid
+             , YesodPersist master
+             , Typeable val
+             ) => HandlerT master IO (Maybe (AuthId master))
+defaultMaybeAuthId = do
+    ms <- lookupSession credsKey
+    case ms of
+        Nothing -> return Nothing
+        Just s ->
+            case fromPathPiece s of
+                Nothing -> return Nothing
+                Just aid -> fmap (fmap entityKey) $ cachedAuth aid
 
-cachedAuth
+cachedAuth :: ( YesodAuth master
-    :: ( MonadHandler m
+             , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
-       , YesodAuthPersist master
+             , b ~ YesodPersistBackend master
-       , Typeable (AuthEntity master)
+             , Key val ~ AuthId master
-       , HandlerSite m ~ master
+             , PersistStore (b (HandlerT master IO))
-       )
+             , PersistEntity val
-    => AuthId master
+             , YesodPersist master
-    -> m (Maybe (AuthEntity master))
+             , Typeable val
-cachedAuth
+             ) => AuthId master -> HandlerT master IO (Maybe (Entity val))
-    = fmap unCachedMaybeAuth
+cachedAuth aid = runMaybeT $ do
-    . cached
+    a <- MaybeT $ fmap unCachedMaybeAuth
-    . fmap CachedMaybeAuth
+                $ cached
-    . getAuthEntity
+                $ fmap CachedMaybeAuth
+                $ runDB
+                $ get aid
+    return $ Entity aid a
 
 
--- | Default handler to show the login page.
+loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)
---
+                   => Route child
--- This is the default 'loginHandler'.  It concatenates plugin widgets and
+                   -> AuthMessage
--- wraps the result in 'authLayout'.  See 'loginHandler' for more details.
+                   -> HandlerT child (HandlerT master m) TypedContent
---
--- @since 1.4.9
-defaultLoginHandler :: AuthHandler master Html
-defaultLoginHandler = do
-    tp <- getRouteToParent
-    authLayout $ do
-        setTitleI Msg.LoginTitle
-        master <- getYesod
-        mapM_ (flip apLogin tp) (authPlugins master)
-
-
-loginErrorMessageI
-  :: Route Auth
-  -> AuthMessage
-  -> AuthHandler master 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
+messageJson401 msg html = selectRep $ do
-  => Text
-  -> m Html
-  -> m TypedContent
-messageJson401 = messageJsonStatus unauthorized401
-
-messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent
-messageJson500 = messageJsonStatus internalServerError500
-
-messageJsonStatus
-  :: MonadHandler m
-  => Status
-  -> Text
-  -> m Html
-  -> m TypedContent
-messageJsonStatus status msg html = selectRep $ do
     provideRep html
     provideRep $ do
         let obj = object ["message" .= msg]
-        void $ sendResponseStatus status obj
+        void $ sendResponseStatus unauthorized401 obj
         return obj
 
 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
+    maid <- getAuthId creds
-    case auth of
+    case maid of
-        Authenticated aid -> do
+        Nothing ->
+            case authRoute y of
+                Nothing -> do
+                    messageJson401 "Invalid Login" $ authLayout $
+                        toWidget [shamlet|<h1>Invalid login|]
+                Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
+        Just aid -> do
             setSession credsKey $ toPathPiece aid
             onLogin
             res <- selectRep $ do
@@ -369,74 +289,43 @@ setCredsRedirect creds = do
                 provideJsonMessage "Login Successful"
             sendResponse res
 
-        UserError msg ->
-            case authRoute y of
-                Nothing -> do
-                    msg' <- renderMessage' msg
-                    messageJson401 msg' $ authLayout $ -- TODO
-                        toWidget [whamlet|<h1>_{msg}|]
-                Just ar -> loginErrorMessageMasterI ar msg
-
-        ServerError msg -> do
-            $(logError) msg
-
-            case authRoute y of
-                Nothing -> do
-                    msg' <- renderMessage' Msg.AuthError
-                    messageJson500 msg' $ authLayout $
-                        toWidget [whamlet|<h1>_{Msg.AuthError}|]
-                Just ar -> loginErrorMessageMasterI ar Msg.AuthError
-
-  where
-    renderMessage' msg = do
-        langs <- languages
-        master <- getYesod
-        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
-      else do auth <- authenticate creds
+      else do maid <- getAuthId creds
-              case auth of
+              case maid of
-                  Authenticated aid -> setSession credsKey $ toPathPiece aid
+                  Nothing -> return ()
-                  _ -> return ()
+                  Just aid -> setSession credsKey $ toPathPiece aid
 
 -- | 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
-    onLogout
+    y <- getYesod
     deleteSession credsKey
-    y  <- getYesod
+    when doRedirects $ do
-    aj <- acceptsJson
+        onLogout
-    case (aj, doRedirects) of
+        redirectUltDest $ logoutDest y
-      (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 +341,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 +354,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,118 +372,67 @@ 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
+maybeAuth :: ( YesodAuth master
-             , val ~ AuthEntity master
+             , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
+             , b ~ YesodPersistBackend master
              , Key val ~ AuthId master
+             , PersistStore (b (HandlerT master IO))
              , PersistEntity val
+             , YesodPersist master
              , Typeable val
-             , MonadHandler m
+             ) => HandlerT master IO (Maybe (Entity val))
-             , HandlerSite m ~ master
+maybeAuth = runMaybeT $ do
-             ) => m (Maybe (Entity val))
-maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
-
--- | Similar to 'maybeAuth', but doesn’t assume that you are using a
--- Persistent database.
---
--- @since 1.4.0
-maybeAuthPair
-  :: ( YesodAuthPersist 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
+    MaybeT $ cachedAuth aid
-    return (aid, ae)
-
 
 newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
+    deriving Typeable
 
--- | Class which states that the given site is an instance of @YesodAuth@
+-- | Constraint 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
+-- and that its @AuthId@ is in fact a persistent @Key@ for the given value.
--- a @YesodPersist@ database.
+-- This is the common case in Yesod, and means that you can easily look up the
+-- full informatin on a given user.
 --
--- The default implementation of @getAuthEntity@ assumes that the @AuthId@
+-- Since 1.2.0
--- for the @YesodAuth@ superclass is in fact a persistent @Key@ for the
+type YesodAuthPersist master =
--- given value.  This is the common case in Yesod, and means that you can
+    ( YesodAuth master
--- easily look up the full information on a given user.
+    , PersistMonadBackend (YesodPersistBackend master (HandlerT master IO))
+        ~ PersistEntityBackend (AuthEntity master)
+    , Key (AuthEntity master) ~ AuthId master
+    , PersistStore (YesodPersistBackend master (HandlerT master IO))
+    , PersistEntity (AuthEntity master)
+    , YesodPersist master
+    , Typeable (AuthEntity master)
+    )
+
+-- | If the @AuthId@ for a given site is a persistent ID, this will give the
+-- value for that entity. E.g.:
 --
--- @since 1.4.0
+-- > type AuthId MySite = UserId
-class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
+-- > AuthEntity MySite ~ User
-    -- | If the @AuthId@ for a given site is a persistent ID, this will give the
+--
-    -- value for that entity. E.g.:
+-- Since 1.2.0
-    --
+type AuthEntity master = KeyEntity (AuthId master)
-    -- > type AuthId MySite = UserId
-    -- > AuthEntity MySite ~ User
-    --
-    -- @since 1.2.0
-    type AuthEntity master :: Type
-    type AuthEntity master = KeyEntity (AuthId master)
-
-    getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)
-                  => AuthId master -> m (Maybe (AuthEntity master))
-
-    default getAuthEntity
-        :: ( YesodPersistBackend master ~ backend
-           , PersistRecordBackend (AuthEntity master) backend
-           , Key (AuthEntity master) ~ AuthId master
-           , PersistStore backend
-           , MonadHandler m
-           , HandlerSite m ~ master
-           )
-        => AuthId master -> m (Maybe (AuthEntity master))
-    getAuthEntity = liftHandler . runDB . get
-
-
-type family KeyEntity key
-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).
+-- authenticated.
 --
--- @since 1.1.0
+-- Since 1.1.0
-requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m))
+requireAuthId :: YesodAuthPersist master => HandlerT master IO (AuthId master)
-requireAuthId = maybeAuthId >>= maybe handleAuthLack return
+requireAuthId = maybeAuthId >>= maybe redirectLogin 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).
+-- authenticated.
 --
--- @since 1.1.0
+-- Since 1.1.0
-requireAuth :: ( YesodAuthPersist master
+requireAuth :: YesodAuthPersist master => HandlerT master IO (Entity (AuthEntity master))
-               , val ~ AuthEntity master
+requireAuth = maybeAuth >>= maybe redirectLogin return
-               , Key val ~ AuthId master
-               , PersistEntity val
-               , Typeable val
-               , MonadHandler m
-               , HandlerSite m ~ master
-               ) => m (Entity val)
-requireAuth = maybeAuth >>= maybe handleAuthLack return
 
--- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
+redirectLogin :: Yesod master => HandlerT master IO a
--- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple.
---
--- @since 1.4.0
-requireAuthPair
-  :: ( YesodAuthPersist 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 = do
-    aj <- acceptsJson
-    if aj then notAuthenticated else redirectLogin
-
-redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
 redirectLogin = do
     y <- getYesod
-    when (redirectToCurrent y) setUltDestCurrent
+    setUltDestCurrent
     case authRoute y of
         Just z -> redirect z
         Nothing -> permissionDenied "Please configure authRoute"
@@ -605,10 +441,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

@@ -2,27 +2,24 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE RecordWildCards #-}
--- | NOTE: Mozilla Persona will be shut down by the end of 2016, therefore this
--- module is no longer recommended for use.
 module Yesod.Auth.BrowserId
-    {-# DEPRECATED "Mozilla Persona will be shut down by the end of 2016" #-}
     ( authBrowserId
     , createOnClick, createOnClickOverride
     , def
     , BrowserIdSettings
     , bisAudience
     , bisLazyLoad
-    , forwardUrl
     ) where
 
 import Yesod.Auth
 import Web.Authenticate.BrowserId
 import Data.Text (Text)
 import Yesod.Core
+import Text.Hamlet (hamlet)
 import qualified Data.Text as T
 import Data.Maybe (fromMaybe)
 import Control.Monad (when, unless)
-import Text.Julius (rawJS)
+import Text.Julius (julius, rawJS)
 import Network.URI (uriPath, parseURI)
 import Data.FileEmbed (embedFile)
 import Data.ByteString (ByteString)
@@ -31,11 +28,8 @@ import Data.Default
 pid :: Text
 pid = "browserid"
 
-forwardUrl :: AuthRoute
+complete :: Route Auth
-forwardUrl = PluginR pid []
+complete = PluginR pid []
-
-complete :: AuthRoute
-complete = forwardUrl
 
 -- | A settings type for various configuration options relevant to BrowserID.
 --
@@ -70,21 +64,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 +110,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 +159,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,76 +1,30 @@
-{-# 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 Text.Hamlet (hamlet)
-import           Yesod.Auth
+import Yesod.Core
-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
+    login authToMaster =
-        request <- getRequest
         toWidget [hamlet|
 $newline never
 <form method="post" action="@{authToMaster url}">
-    $maybe t <- reqToken request
-        <input type=hidden name=#{defaultCsrfParamName} value=#{t}>
     Your new identifier is: #
     <input type="text" name="ident">
     <input type="submit" value="Dummy Login">

yesod-auth/Yesod/Auth/GoogleEmail.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# 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
+    ( 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 :: YesodAuth master => [(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

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

yesod-auth/Yesod/Auth/Hardcoded.hs

@@ -1,199 +0,0 @@
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-|
-Module      : Yesod.Auth.Hardcoded
-Description : Very simple auth plugin for hardcoded auth pairs.
-Copyright   : (c) Arthur Fayzrakhmanov, 2015
-License     : MIT
-Maintainer  : heraldhoi@gmail.com
-Stability   : experimental
-
-Sometimes you may want to have some hardcoded set of users (e.g. site managers)
-that allowed to log in and visit some specific sections of your website without
-ability to register new managers.  This simple plugin is designed exactly for
-this purpose.
-
-Here is a quick usage example.
-
-== Define hardcoded users representation
-
-Let's assume, that we want to have some hardcoded managers with normal site
-users.  Let's define hardcoded user representation:
-
-@
-data SiteManager = SiteManager
-  { manUserName :: Text
-  , manPassWord :: Text }
-  deriving Show
-
-siteManagers :: [SiteManager]
-siteManagers = [SiteManager "content editor" "top secret"]
-@
-
-
-== Describe 'YesodAuth' instance
-
-Now we need to have some convenient 'AuthId' type representing both
-cases:
-
-@
-instance YesodAuth App where
-  type AuthId App = Either UserId Text
-@
-
-Here, right @Text@ value will present hardcoded user name (which obviously must
-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:
-
-@
-import Text.Read (readMaybe)
-
-instance PathPiece (Either UserId Text) where
-  fromPathPiece = readMaybe . unpack
-  toPathPiece = pack . show
-@
-
-Quiet simple so far.  Now let's add plugin to 'authPlugins' list, and define
-'authenticate' method, it should return user identifier for given credentials,
-for normal users it is usually persistent key, for hardcoded users we will
-return user name again.
-
-@
-instance YesodAuth App where
-  -- ..
-  authPlugins _ = [authHardcoded]
-
-  authenticate Creds{..} =
-    return
-      (case credsPlugin of
-         "hardcoded" ->
-           case lookupUser credsIdent of
-             Nothing -> UserError InvalidLogin
-             Just m  -> Authenticated (Right (manUserName m)))
-@
-
-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
-@
-
-
-== Describe an 'YesodAuthPersist' instance
-
-Now we need to manually define 'YesodAuthPersist' instance.
-
-> instance YesodAuthPersist App where
->   type AuthEntity App = Either User SiteManager
->
->   getAuthEntity (Left uid) =
->     do x <- runDB (get uid)
->        return (Left <$> x)
->   getAuthEntity (Right username) = return (Right <$> lookupUser username)
-
-
-== Define 'YesodAuthHardcoded' instance
-
-Finally, let's define an plugin instance
-
-@
-instance YesodAuthHardcoded App where
-  validatePassword u = return . validPassword u
-  doesUserNameExist  = return . isJust . lookupUser
-
-validPassword :: Text -> Text -> Bool
-validPassword u p =
-  case find (\\m -> manUserName m == u && manPassWord m == p) siteManagers of
-    Just _ -> True
-    _      -> False
-@
-
-
-== Conclusion
-
-Now we can use 'maybeAuthId', 'maybeAuthPair', 'requireAuthId', and
-'requireAuthPair', moreover, the returned value makes possible to distinguish
-normal users and site managers.
--}
-module Yesod.Auth.Hardcoded
-  ( YesodAuthHardcoded(..)
-  , authHardcoded
-  , loginR )
-  where
-
-import           Yesod.Auth          (AuthHandler, AuthPlugin (..), AuthRoute,
-                                      Creds (..), Route (..), YesodAuth,
-                                      loginErrorMessageI, setCredsRedirect)
-import qualified Yesod.Auth.Message  as Msg
-import           Yesod.Core
-import           Yesod.Form          (ireq, runInputPost, textField)
-
-import           Control.Applicative ((<$>), (<*>))
-import           Data.Text           (Text)
-
-
-loginR :: AuthRoute
-loginR = PluginR "hardcoded" ["login"]
-
-class (YesodAuth site) => YesodAuthHardcoded site where
-
-  -- | Check whether given user name exists among hardcoded names.
-  doesUserNameExist :: Text -> AuthHandler site Bool
-
-  -- | Validate given user name with given password.
-  validatePassword :: Text -> Text -> AuthHandler site 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
-    loginWidget toMaster = do
-      request <- getRequest
-      [whamlet|
-        $newline never
-        <form method="post" action="@{toMaster loginR}">
-          $maybe t <- reqToken request
-            <input type=hidden name=#{defaultCsrfParamName} value=#{t}>
-          <table>
-            <tr>
-              <th>_{Msg.UserName}
-              <td>
-                 <input type="text" name="username" required>
-            <tr>
-              <th>_{Msg.Password}
-              <td>
-                 <input type="password" name="password" required>
-            <tr>
-              <td colspan="2">
-                 <button type="submit" .btn .btn-success>_{Msg.LoginTitle}
-        |]
-
-
-postLoginR :: YesodAuthHardcoded site
-           => AuthHandler site TypedContent
-postLoginR =
-  do (username, password) <- runInputPost
-       ((,) Control.Applicative.<$> ireq textField "username"
-            Control.Applicative.<*> ireq textField "password")
-     isValid <- validatePassword username password
-     if isValid
-        then setCredsRedirect (Creds "hardcoded" username [])
-        else do isExists <- doesUserNameExist username
-                loginErrorMessageI LoginR
-                                   (if isExists
-                                       then Msg.InvalidUsernamePass
-                                       else Msg.IdentifierNotFound username)

yesod-auth/Yesod/Auth/Message.hs

@@ -13,17 +13,12 @@ module Yesod.Auth.Message
     , japaneseMessage
     , finnishMessage
     , chineseMessage
-    , croatianMessage
     , spanishMessage
     , czechMessage
-    , russianMessage
-    , dutchMessage
-    , danishMessage
-    , koreanMessage
     ) where
 
-import           Data.Monoid (mappend, (<>))
+import Data.Monoid (mappend)
-import           Data.Text   (Text)
+import Data.Text (Text)
 
 data AuthMessage =
       NoOpenID
@@ -31,7 +26,6 @@ data AuthMessage =
     | LoginGoogle
     | LoginYahoo
     | Email
-    | UserName
     | IdentifierNotFound Text
     | Password
     | Register
@@ -40,8 +34,6 @@ data AuthMessage =
     | ConfirmationEmailSentTitle
     | ConfirmationEmailSent Text
     | AddressVerified
-    | EmailVerifiedChangePass
-    | EmailVerified
     | InvalidKeyTitle
     | InvalidKey
     | InvalidEmailPass
@@ -65,13 +57,7 @@ data AuthMessage =
     | ProvideIdentifier
     | SendPasswordResetEmail
     | PasswordResetPrompt
-    | CurrentPassword
     | InvalidUsernamePass
-    | Logout
-    | LogoutTitle
-    | AuthError
-{-# DEPRECATED Logout "Please, use LogoutTitle instead." #-}
-{-# DEPRECATED AddressVerified "Please, use EmailVerifiedChangePass instead." #-}
 
 -- | Defaults to 'englishMessage'.
 defaultMessage :: AuthMessage -> Text
@@ -79,24 +65,20 @@ defaultMessage = englishMessage
 
 englishMessage :: AuthMessage -> Text
 englishMessage NoOpenID = "No OpenID identifier found"
-englishMessage LoginOpenID = "Log in via OpenID"
+englishMessage LoginOpenID = "Login via OpenID"
-englishMessage LoginGoogle = "Log in via Google"
+englishMessage LoginGoogle = "Login via Google"
-englishMessage LoginYahoo = "Log in via Yahoo"
+englishMessage LoginYahoo = "Login via Yahoo"
 englishMessage Email = "Email"
-englishMessage UserName = "User name"
 englishMessage Password = "Password"
-englishMessage CurrentPassword = "Current Password"
 englishMessage Register = "Register"
 englishMessage RegisterLong = "Register a new account"
 englishMessage EnterEmail = "Enter your e-mail address below, and a confirmation e-mail will be sent to you."
 englishMessage ConfirmationEmailSentTitle = "Confirmation e-mail sent"
 englishMessage (ConfirmationEmailSent email) =
-    "A confirmation e-mail has been sent to " `Data.Monoid.mappend`
+    "A confirmation e-mail has been sent to " `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"
@@ -107,11 +89,11 @@ englishMessage NewPass = "New password"
 englishMessage ConfirmPass = "Confirm"
 englishMessage PassMismatch = "Passwords did not match, please try again"
 englishMessage PassUpdated = "Password updated"
-englishMessage Facebook = "Log in with Facebook"
+englishMessage Facebook = "Login with Facebook"
-englishMessage LoginViaEmail = "Log in via email"
+englishMessage LoginViaEmail = "Login via email"
 englishMessage InvalidLogin = "Invalid login"
 englishMessage NowLoggedIn = "You are now logged in"
-englishMessage LoginTitle = "Log In"
+englishMessage LoginTitle = "Login"
 englishMessage PleaseProvideUsername = "Please fill in your username"
 englishMessage PleaseProvidePassword = "Please fill in your password"
 englishMessage NoIdentifierProvided = "No email/username provided"
@@ -122,9 +104,6 @@ englishMessage SendPasswordResetEmail = "Send password reset email"
 englishMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
 englishMessage InvalidUsernamePass = "Invalid username/password combination"
 englishMessage (IdentifierNotFound ident) = "Login not found: " `mappend` ident
-englishMessage Logout = "Log Out"
-englishMessage LogoutTitle = "Log Out"
-englishMessage AuthError = "Authentication Error" -- FIXME by Google Translate
 
 portugueseMessage :: AuthMessage -> Text
 portugueseMessage NoOpenID = "Nenhum identificador OpenID encontrado"
@@ -132,9 +111,7 @@ portugueseMessage LoginOpenID = "Entrar via OpenID"
 portugueseMessage LoginGoogle = "Entrar via Google"
 portugueseMessage LoginYahoo = "Entrar via Yahoo"
 portugueseMessage Email = "E-mail"
-portugueseMessage UserName = "Nome de usuário" -- FIXME by Google Translate "user name"
 portugueseMessage Password = "Senha"
-portugueseMessage CurrentPassword = "Palavra de passe"
 portugueseMessage Register = "Registrar"
 portugueseMessage RegisterLong = "Registrar uma nova conta"
 portugueseMessage EnterEmail = "Por favor digite seu endereço de e-mail abaixo e um e-mail de confirmação será enviado para você."
@@ -144,8 +121,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"
@@ -172,9 +147,6 @@ portugueseMessage PasswordResetPrompt = "Insira seu endereço de e-mail ou nome
 portugueseMessage InvalidUsernamePass = "Nome de usuário ou senha inválidos"
 -- TODO
 portugueseMessage i@(IdentifierNotFound _) = englishMessage i
-portugueseMessage Logout = "Sair" -- FIXME by Google Translate
-portugueseMessage LogoutTitle = "Sair" -- FIXME by Google Translate
-portugueseMessage AuthError = "Erro de autenticação" -- FIXME by Google Translate
 
 spanishMessage :: AuthMessage -> Text
 spanishMessage NoOpenID = "No se encuentra el identificador OpenID"
@@ -182,9 +154,7 @@ spanishMessage LoginOpenID = "Entrar utilizando OpenID"
 spanishMessage LoginGoogle = "Entrar utilizando Google"
 spanishMessage LoginYahoo = "Entrar utilizando Yahoo"
 spanishMessage Email = "Correo electrónico"
-spanishMessage UserName = "Nombre de Usuario"
 spanishMessage Password = "Contraseña"
-spanishMessage CurrentPassword = "Contraseña actual"
 spanishMessage Register = "Registrarse"
 spanishMessage RegisterLong = "Registrar una nueva cuenta"
 spanishMessage EnterEmail = "Coloque su dirección de correo electrónico, y un correo de confirmación le será enviado a su cuenta."
@@ -194,8 +164,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"
@@ -210,21 +178,18 @@ spanishMessage Facebook = "Entrar mediante Facebook"
 spanishMessage LoginViaEmail = "Entrar mediante una cuenta de correo"
 spanishMessage InvalidLogin = "Login inválido"
 spanishMessage NowLoggedIn = "Usted ha ingresado al sitio"
-spanishMessage LoginTitle = "Log In"
+spanishMessage LoginTitle = "Login"
 spanishMessage PleaseProvideUsername = "Por favor escriba su nombre de usuario"
 spanishMessage PleaseProvidePassword = "Por favor escriba su contraseña"
 spanishMessage NoIdentifierProvided = "No ha indicado una cuenta de correo/nombre de usuario"
 spanishMessage InvalidEmailAddress = "La cuenta de correo es inválida"
-spanishMessage PasswordResetTitle = "Actualización de contraseña"
+spanishMessage PasswordResetTitle = "Contraseña actualizada"
 spanishMessage ProvideIdentifier = "Cuenta de correo o nombre de usuario"
-spanishMessage SendPasswordResetEmail = "Enviar correo de actualización de contraseña"
+spanishMessage SendPasswordResetEmail = "Correo de actualización de contraseña enviado"
 spanishMessage PasswordResetPrompt = "Escriba su cuenta de correo o nombre de usuario, y una confirmación de actualización de contraseña será enviada a su cuenta de correo."
 spanishMessage InvalidUsernamePass = "Combinación de nombre de usuario/contraseña invalida"
 -- TODO
 spanishMessage i@(IdentifierNotFound _) = englishMessage i
-spanishMessage Logout = "Finalizar la sesión" -- FIXME by Google Translate
-spanishMessage LogoutTitle = "Finalizar la sesión" -- FIXME by Google Translate
-spanishMessage AuthError = "Error de autenticación" -- FIXME by Google Translate
 
 swedishMessage :: AuthMessage -> Text
 swedishMessage NoOpenID = "Fann ej OpenID identifierare"
@@ -232,9 +197,7 @@ swedishMessage LoginOpenID = "Logga in via OpenID"
 swedishMessage LoginGoogle = "Logga in via Google"
 swedishMessage LoginYahoo = "Logga in via Yahoo"
 swedishMessage Email = "Epost"
-swedishMessage UserName = "Användarnamn"  -- FIXME by Google Translate "user name"
 swedishMessage Password = "Lösenord"
-swedishMessage CurrentPassword = "Current password"
 swedishMessage Register = "Registrera"
 swedishMessage RegisterLong = "Registrera ett nytt konto"
 swedishMessage EnterEmail = "Skriv in din epost nedan så kommer ett konfirmationsmail skickas till adressen."
@@ -244,8 +207,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"
@@ -273,30 +234,23 @@ swedishMessage PasswordResetPrompt = "Skriv in din emailadress eller användarna
 swedishMessage InvalidUsernamePass = "Ogiltig kombination av användarnamn och lösenord"
 -- TODO
 swedishMessage i@(IdentifierNotFound _) = englishMessage i
-swedishMessage Logout = "Loggar ut" -- FIXME by Google Translate
-swedishMessage LogoutTitle = "Loggar ut" -- FIXME by Google Translate
-swedishMessage AuthError = "Autentisering Fel" -- FIXME by Google Translate
 
 germanMessage :: AuthMessage -> Text
 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 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."
+    "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"
@@ -305,26 +259,24 @@ germanMessage SetPassTitle = "Passwort angeben"
 germanMessage SetPass = "Neues Passwort angeben"
 germanMessage NewPass = "Neues Passwort"
 germanMessage ConfirmPass = "Bestätigen"
-germanMessage PassMismatch = "Die Passwörter stimmen nicht überein"
+germanMessage PassMismatch = "Die Passwörter stimmten 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 = "Login"
 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 AuthError = "Fehler beim Anmelden"
 
 frenchMessage :: AuthMessage -> Text
 frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"
@@ -332,9 +284,7 @@ frenchMessage LoginOpenID = "Se connecter avec OpenID"
 frenchMessage LoginGoogle = "Se connecter avec Google"
 frenchMessage LoginYahoo = "Se connecter avec Yahoo"
 frenchMessage Email = "Adresse électronique"
-frenchMessage UserName = "Nom d'utilisateur" -- FIXME by Google Translate "user name"
 frenchMessage Password = "Mot de passe"
-frenchMessage CurrentPassword = "Mot de passe actuel"
 frenchMessage Register = "S'inscrire"
 frenchMessage RegisterLong = "Créer un compte"
 frenchMessage EnterEmail = "Entrez ci-dessous votre adresse électronique, et un message de confirmation vous sera envoyé"
@@ -344,11 +294,9 @@ 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."
+frenchMessage InvalidEmailPass = "Le couple mot de passe/adresse électronique n'est pas correct"
 frenchMessage BadSetPass = "Vous devez être connecté pour choisir un mot de passe"
 frenchMessage SetPassTitle = "Changer de mot de passe"
 frenchMessage SetPass = "Choisir un nouveau mot de passe"
@@ -357,23 +305,20 @@ frenchMessage ConfirmPass = "Confirmation du mot de passe"
 frenchMessage PassMismatch = "Le deux mots de passe sont différents, veuillez les corriger"
 frenchMessage PassUpdated = "Le mot de passe a bien été changé"
 frenchMessage Facebook = "Se connecter avec Facebook"
-frenchMessage LoginViaEmail = "Se connecter avec une adresse électronique"
+frenchMessage LoginViaEmail = "Se connecter à l'aide d'une adresse électronique"
 frenchMessage InvalidLogin = "Nom d'utilisateur incorrect"
 frenchMessage NowLoggedIn = "Vous êtes maintenant connecté"
 frenchMessage LoginTitle = "Se connecter"
-frenchMessage PleaseProvideUsername = "Veuillez fournir votre nom d'utilisateur"
+frenchMessage PleaseProvideUsername = "Merci de renseigner votre nom d'utilisateur"
-frenchMessage PleaseProvidePassword = "Veuillez fournir votre mot de passe"
+frenchMessage PleaseProvidePassword = "Merci de spécifier un mot de passe"
 frenchMessage NoIdentifierProvided = "Adresse électronique/nom d'utilisateur non spécifié"
 frenchMessage InvalidEmailAddress = "Adresse électronique spécifiée invalide"
-frenchMessage PasswordResetTitle = "Réinitialisation du mot de passe"
+frenchMessage PasswordResetTitle = "Réinitialisation de mot de passe"
 frenchMessage ProvideIdentifier = "Adresse électronique ou nom d'utilisateur"
-frenchMessage SendPasswordResetEmail = "Envoi d'un courriel pour réinitialiser le mot de passe"
+frenchMessage SendPasswordResetEmail = "Envoie d'un message électronique pour Réinitialisation le mot de passe"
-frenchMessage PasswordResetPrompt = "Entrez votre courriel ou votre nom d'utilisateur ci-dessous, et vous recevrez un message électronique pour réinitialiser votre mot de passe."
+frenchMessage PasswordResetPrompt = "Entrez votre adresse électronique ou votre nom d'utilisateur ci-dessous, et un message électronique de réinitialisation de mot de passe vous sera envoyé."
-frenchMessage InvalidUsernamePass = "La combinaison de ce mot de passe et de ce nom d'utilisateur n'existe pas."
+frenchMessage InvalidUsernamePass = "Le couble nom d'utilisateur/mot de passe invalide"
 frenchMessage (IdentifierNotFound ident) = "Nom d'utilisateur introuvable: " `mappend` ident
-frenchMessage Logout = "Déconnexion"
-frenchMessage LogoutTitle = "Déconnexion"
-frenchMessage AuthError = "Erreur d'authentification" -- FIXME by Google Translate
 
 norwegianBokmålMessage :: AuthMessage -> Text
 norwegianBokmålMessage NoOpenID = "Ingen OpenID-identifiserer funnet"
@@ -381,9 +326,7 @@ norwegianBokmålMessage LoginOpenID = "Logg inn med OpenID"
 norwegianBokmålMessage LoginGoogle = "Logg inn med Google"
 norwegianBokmålMessage LoginYahoo = "Logg inn med Yahoo"
 norwegianBokmålMessage Email = "E-post"
-norwegianBokmålMessage UserName = "Brukernavn" -- FIXME by Google Translate "user name"
 norwegianBokmålMessage Password = "Passord"
-norwegianBokmålMessage CurrentPassword = "Current password"
 norwegianBokmålMessage Register = "Registrer"
 norwegianBokmålMessage RegisterLong = "Registrer en ny konto"
 norwegianBokmålMessage EnterEmail = "Skriv inn e-postadressen din nedenfor og en e-postkonfirmasjon vil bli sendt."
@@ -393,8 +336,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"
@@ -421,9 +362,6 @@ norwegianBokmålMessage PasswordResetPrompt = "Enter your e-mail address or user
 norwegianBokmålMessage InvalidUsernamePass = "Invalid username/password combination"
 -- TODO
 norwegianBokmålMessage i@(IdentifierNotFound _) = englishMessage i
-norwegianBokmålMessage Logout = "Logge ut" -- FIXME by Google Translate
-norwegianBokmålMessage LogoutTitle = "Logge ut" -- FIXME by Google Translate
-norwegianBokmålMessage AuthError = "Godkjenningsfeil" -- FIXME by Google Translate
 
 japaneseMessage :: AuthMessage -> Text
 japaneseMessage NoOpenID = "OpenID識別子がありません"
@@ -431,9 +369,7 @@ japaneseMessage LoginOpenID = "OpenIDでログイン"
 japaneseMessage LoginGoogle = "Googleでログイン"
 japaneseMessage LoginYahoo = "Yahooでログイン"
 japaneseMessage Email = "Eメール"
-japaneseMessage UserName = "ユーザー名" -- FIXME by Google Translate "user name"
 japaneseMessage Password = "パスワード"
-japaneseMessage CurrentPassword = "現在のパスワード"
 japaneseMessage Register = "登録"
 japaneseMessage RegisterLong = "新規アカウント登録"
 japaneseMessage EnterEmail = "メールアドレスを入力してください。確認メールが送られます"
@@ -443,8 +379,6 @@ japaneseMessage (ConfirmationEmailSent email) =
     email `mappend`
     " に送信しました"
 japaneseMessage AddressVerified = "アドレスは認証されました。新しいパスワードを設定してください"
-japaneseMessage EmailVerifiedChangePass = "アドレスは認証されました。新しいパスワードを設定してください"
-japaneseMessage EmailVerified = "アドレスは認証されました"
 japaneseMessage InvalidKeyTitle = "認証キーが無効です"
 japaneseMessage InvalidKey = "申し訳ありません。無効な認証キーです"
 japaneseMessage InvalidEmailPass = "メールアドレスまたはパスワードが無効です"
@@ -462,18 +396,15 @@ japaneseMessage NowLoggedIn = "ログインしました"
 japaneseMessage LoginTitle = "ログイン"
 japaneseMessage PleaseProvideUsername = "ユーザ名を入力してください"
 japaneseMessage PleaseProvidePassword = "パスワードを入力してください"
-japaneseMessage NoIdentifierProvided = "メールアドレス/ユーザ名が入力されていません"
+japaneseMessage NoIdentifierProvided = "No email/username provided"
-japaneseMessage InvalidEmailAddress = "メールアドレスが無効です"
+japaneseMessage InvalidEmailAddress = "Invalid email address provided"
-japaneseMessage PasswordResetTitle = "パスワードの再設定"
+japaneseMessage PasswordResetTitle = "Password Reset"
-japaneseMessage ProvideIdentifier = "メールアドレスまたはユーザ名"
+japaneseMessage ProvideIdentifier = "Email or Username"
-japaneseMessage SendPasswordResetEmail = "パスワード再設定用メールの送信"
+japaneseMessage SendPasswordResetEmail = "Send password reset email"
-japaneseMessage PasswordResetPrompt = "以下にメールアドレスまたはユーザ名を入力してください。パスワードを再設定するためのメールが送信されます。"
+japaneseMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
-japaneseMessage InvalidUsernamePass = "ユーザ名とパスワードの組み合わせが間違っています"
+japaneseMessage InvalidUsernamePass = "Invalid username/password combination"
 japaneseMessage (IdentifierNotFound ident) =
-  ident `mappend` "は登録されていません"
+  "「" `mappend` ident `mappend` "」は正しくないログインので、または未入力の項目があります。"
-japaneseMessage Logout = "ログアウト" -- FIXME by Google Translate
-japaneseMessage LogoutTitle = "ログアウト" -- FIXME by Google Translate
-japaneseMessage AuthError = "認証エラー" -- FIXME by Google Translate
 
 finnishMessage :: AuthMessage -> Text
 finnishMessage NoOpenID = "OpenID-tunnistetta ei löydy"
@@ -481,9 +412,7 @@ finnishMessage LoginOpenID = "Kirjaudu OpenID-tilillä"
 finnishMessage LoginGoogle = "Kirjaudu Google-tilillä"
 finnishMessage LoginYahoo = "Kirjaudu Yahoo-tilillä"
 finnishMessage Email = "Sähköposti"
-finnishMessage UserName = "Käyttäjätunnus" -- FIXME by Google Translate "user name"
 finnishMessage Password = "Salasana"
-finnishMessage CurrentPassword = "Current password"
 finnishMessage Register = "Luo uusi"
 finnishMessage RegisterLong = "Luo uusi tili"
 finnishMessage EnterEmail = "Kirjoita alle sähköpostiosoitteesi, johon vahvistussähköposti lähetetään."
@@ -494,8 +423,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."
@@ -522,9 +449,6 @@ finnishMessage PasswordResetPrompt = "Anna sähköpostiosoitteesi tai käyttäj
 finnishMessage InvalidUsernamePass = "Virheellinen käyttäjänimi tai salasana."
 -- TODO
 finnishMessage i@(IdentifierNotFound _) = englishMessage i
-finnishMessage Logout = "Kirjaudu ulos" -- FIXME by Google Translate
-finnishMessage LogoutTitle = "Kirjaudu ulos" -- FIXME by Google Translate
-finnishMessage AuthError = "Authentication Error" -- FIXME by Google Translate
 
 chineseMessage :: AuthMessage -> Text
 chineseMessage NoOpenID = "无效的OpenID"
@@ -532,9 +456,7 @@ chineseMessage LoginOpenID = "用OpenID登录"
 chineseMessage LoginGoogle = "用Google帐户登录"
 chineseMessage LoginYahoo = "用Yahoo帐户登录"
 chineseMessage Email = "邮箱"
-chineseMessage UserName = "用户名"
 chineseMessage Password = "密码"
-chineseMessage CurrentPassword = "当前密码"
 chineseMessage Register = "注册"
 chineseMessage RegisterLong = "注册新帐户"
 chineseMessage EnterEmail = "输入你的邮箱地址，你将收到一封确认邮件。"
@@ -544,8 +466,6 @@ chineseMessage (ConfirmationEmailSent email) =
     email `mappend`
     "."
 chineseMessage AddressVerified = "地址验证成功，请设置新密码"
-chineseMessage EmailVerifiedChangePass = "地址验证成功，请设置新密码"
-chineseMessage EmailVerified = "地址验证成功"
 chineseMessage InvalidKeyTitle = "无效的验证码"
 chineseMessage InvalidKey = "对不起，验证码无效。"
 chineseMessage InvalidEmailPass = "无效的邮箱/密码组合"
@@ -570,10 +490,8 @@ chineseMessage ProvideIdentifier = "邮箱或用户名"
 chineseMessage SendPasswordResetEmail = "发送密码重置邮件"
 chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。"
 chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"
-chineseMessage (IdentifierNotFound ident) = "邮箱/用户名不存在: " `mappend` ident
+-- TODO
-chineseMessage Logout = "注销"
+chineseMessage i@(IdentifierNotFound _) = englishMessage i
-chineseMessage LogoutTitle = "注销"
-chineseMessage AuthError = "验证错误"
 
 czechMessage :: AuthMessage -> Text
 czechMessage NoOpenID = "Nebyl nalezen identifikátor OpenID"
@@ -581,9 +499,7 @@ czechMessage LoginOpenID = "Přihlásit přes OpenID"
 czechMessage LoginGoogle = "Přihlásit přes Google"
 czechMessage LoginYahoo = "Přihlásit přes Yahoo"
 czechMessage Email = "E-mail"
-czechMessage UserName = "Uživatelské jméno"
 czechMessage Password = "Heslo"
-czechMessage CurrentPassword = "Current password"
 czechMessage Register = "Registrovat"
 czechMessage RegisterLong = "Zaregistrovat nový účet"
 czechMessage EnterEmail = "Níže zadejte svou e-mailovou adresu a bude vám poslán potvrzovací e-mail."
@@ -591,8 +507,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"
@@ -619,250 +533,3 @@ czechMessage PasswordResetPrompt = "Zadejte svou e-mailovou adresu nebo uživate
 czechMessage InvalidUsernamePass = "Neplatná kombinace uživatelského jména a hesla"
 -- TODO
 czechMessage i@(IdentifierNotFound _) = englishMessage i
-czechMessage Logout = "Odhlásit" -- FIXME by Google Translate
-czechMessage LogoutTitle = "Odhlásit" -- FIXME by Google Translate
-czechMessage AuthError = "Chyba ověřování" -- FIXME by Google Translate
-
--- Так как e-mail – это фактическое сокращение словосочетания electronic mail,
--- для русского перевода так же использовано сокращение: эл.почта
-russianMessage :: AuthMessage -> Text
-russianMessage NoOpenID = "Идентификатор OpenID не найден"
-russianMessage LoginOpenID = "Вход с помощью OpenID"
-russianMessage LoginGoogle = "Вход с помощью Google"
-russianMessage LoginYahoo = "Вход с помощью Yahoo"
-russianMessage Email = "Эл.почта"
-russianMessage UserName = "Имя пользователя"
-russianMessage Password = "Пароль"
-russianMessage CurrentPassword = "Старый пароль"
-russianMessage Register = "Регистрация"
-russianMessage RegisterLong = "Создать учётную запись"
-russianMessage EnterEmail = "Введите свой адрес эл.почты ниже, вам будет отправлено письмо для подтверждения."
-russianMessage ConfirmationEmailSentTitle = "Письмо для подтверждения отправлено"
-russianMessage (ConfirmationEmailSent email) =
-    "Письмо для подтверждения было отправлено на адрес " `mappend`
-    email `mappend`
-    "."
-russianMessage AddressVerified = "Адрес подтверждён. Пожалуйста, установите новый пароль."
-russianMessage EmailVerifiedChangePass = "Адрес подтверждён. Пожалуйста, установите новый пароль."
-russianMessage EmailVerified = "Адрес подтверждён"
-russianMessage InvalidKeyTitle = "Неверный ключ подтверждения"
-russianMessage InvalidKey = "Извините, но ключ подтверждения оказался недействительным."
-russianMessage InvalidEmailPass = "Неверное сочетание эл.почты и пароля"
-russianMessage BadSetPass = "Чтобы изменить пароль, необходимо выполнить вход"
-russianMessage SetPassTitle = "Установить пароль"
-russianMessage SetPass = "Установить новый пароль"
-russianMessage NewPass = "Новый пароль"
-russianMessage ConfirmPass = "Подтверждение пароля"
-russianMessage PassMismatch = "Пароли не совпадают, повторите снова"
-russianMessage PassUpdated = "Пароль обновлён"
-russianMessage Facebook = "Войти с помощью Facebook"
-russianMessage LoginViaEmail = "Войти по адресу эл.почты"
-russianMessage InvalidLogin = "Неверный логин"
-russianMessage NowLoggedIn = "Вход выполнен"
-russianMessage LoginTitle = "Войти"
-russianMessage PleaseProvideUsername = "Пожалуйста, введите ваше имя пользователя"
-russianMessage PleaseProvidePassword = "Пожалуйста, введите ваш пароль"
-russianMessage NoIdentifierProvided = "Не указан адрес эл.почты/имя пользователя"
-russianMessage InvalidEmailAddress = "Указан неверный адрес эл.почты"
-russianMessage PasswordResetTitle = "Сброс пароля"
-russianMessage ProvideIdentifier = "Имя пользователя или эл.почта"
-russianMessage SendPasswordResetEmail = "Отправить письмо для сброса пароля"
-russianMessage PasswordResetPrompt = "Введите адрес эл.почты или ваше имя пользователя ниже, вам будет отправлено письмо для сброса пароля."
-russianMessage InvalidUsernamePass = "Неверное сочетание имени пользователя и пароля"
-russianMessage (IdentifierNotFound ident) = "Логин не найден: " `mappend` ident
-russianMessage Logout = "Выйти"
-russianMessage LogoutTitle = "Выйти"
-russianMessage AuthError = "Ошибка аутентификации"
-
-dutchMessage :: AuthMessage -> Text
-dutchMessage NoOpenID = "Geen OpenID identificator gevonden"
-dutchMessage LoginOpenID = "Inloggen via OpenID"
-dutchMessage LoginGoogle = "Inloggen via Google"
-dutchMessage LoginYahoo = "Inloggen via Yahoo"
-dutchMessage Email = "E-mail"
-dutchMessage UserName = "Gebruikersnaam"
-dutchMessage Password = "Wachtwoord"
-dutchMessage CurrentPassword = "Huidig wachtwoord"
-dutchMessage Register = "Registreren"
-dutchMessage RegisterLong = "Registreer een nieuw account"
-dutchMessage EnterEmail = "Voer uw e-mailadres hieronder in, er zal een bevestigings-e-mail naar u worden verzonden."
-dutchMessage ConfirmationEmailSentTitle = "Bevestigings-e-mail verzonden"
-dutchMessage (ConfirmationEmailSent email) =
-    "Een bevestigings-e-mail is verzonden naar " `mappend`
-    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"
-dutchMessage BadSetPass = "U moet ingelogd zijn om een nieuwe wachtwoord in te stellen"
-dutchMessage SetPassTitle = "Wachtwoord instellen"
-dutchMessage SetPass = "Een nieuwe wachtwoord instellen"
-dutchMessage NewPass = "Nieuw wachtwoord"
-dutchMessage ConfirmPass = "Bevestig"
-dutchMessage PassMismatch = "Wachtwoorden kwamen niet overeen, probeer het alstublieft nog eens"
-dutchMessage PassUpdated = "Wachtwoord geüpdatet"
-dutchMessage Facebook = "Inloggen met Facebook"
-dutchMessage LoginViaEmail = "Inloggen via e-mail"
-dutchMessage InvalidLogin = "Ongeldige inloggegevens"
-dutchMessage NowLoggedIn = "U bent nu ingelogd"
-dutchMessage LoginTitle = "Inloggen"
-dutchMessage PleaseProvideUsername = "Voer alstublieft uw gebruikersnaam in"
-dutchMessage PleaseProvidePassword = "Voer alstublieft uw wachtwoord in"
-dutchMessage NoIdentifierProvided = "Geen e-mailadres/gebruikersnaam opgegeven"
-dutchMessage InvalidEmailAddress = "Ongeldig e-mailadres opgegeven"
-dutchMessage PasswordResetTitle = "Wachtwoord wijzigen"
-dutchMessage ProvideIdentifier = "E-mailadres of gebruikersnaam"
-dutchMessage SendPasswordResetEmail = "Stuur een wachtwoord reset e-mail"
-dutchMessage PasswordResetPrompt = "Voer uw e-mailadres of gebruikersnaam hieronder in, er zal een e-mail naar u worden verzonden waarmee u uw wachtwoord kunt wijzigen."
-dutchMessage InvalidUsernamePass = "Ongeldige gebruikersnaam/wachtwoord combinatie"
-dutchMessage (IdentifierNotFound ident) = "Inloggegevens niet gevonden: " `mappend` ident
-dutchMessage Logout = "Uitloggen"
-dutchMessage LogoutTitle = "Uitloggen"
-dutchMessage AuthError = "Verificatiefout"
-
-croatianMessage :: AuthMessage -> Text
-croatianMessage NoOpenID = "Nije pronađen OpenID identifikator"
-croatianMessage LoginOpenID = "Prijava uz OpenID"
-croatianMessage LoginGoogle = "Prijava uz Google"
-croatianMessage LoginYahoo = "Prijava uz Yahoo"
-croatianMessage Facebook = "Prijava uz Facebook"
-croatianMessage LoginViaEmail = "Prijava putem e-pošte"
-croatianMessage Email = "E-pošta"
-croatianMessage UserName = "Korisničko ime"
-croatianMessage Password = "Lozinka"
-croatianMessage CurrentPassword = "Current Password"
-croatianMessage Register = "Registracija"
-croatianMessage RegisterLong = "Registracija novog računa"
-croatianMessage EnterEmail = "Dolje unesite adresu e-pošte, pa ćemo vam poslati e-poruku za potvrdu."
-croatianMessage PasswordResetPrompt = "Dolje unesite adresu e-pošte ili korisničko ime, pa ćemo vam poslati e-poruku za potvrdu."
-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"
-croatianMessage InvalidUsernamePass = "Kombinacija korisničkog imena i lozinke nije valjana"
-croatianMessage BadSetPass = "Za postavljanje lozinke morate biti prijavljeni"
-croatianMessage SetPassTitle = "Postavi lozinku"
-croatianMessage SetPass = "Postavite novu lozinku"
-croatianMessage NewPass = "Nova lozinka"
-croatianMessage ConfirmPass = "Potvrda lozinke"
-croatianMessage PassMismatch = "Lozinke se ne podudaraju, pokušajte ponovo"
-croatianMessage PassUpdated = "Lozinka ažurirana"
-croatianMessage InvalidLogin = "Prijava nije valjana"
-croatianMessage NowLoggedIn = "Sada ste prijavljeni u"
-croatianMessage LoginTitle = "Prijava"
-croatianMessage PleaseProvideUsername = "Unesite korisničko ime"
-croatianMessage PleaseProvidePassword = "Unesite lozinku"
-croatianMessage NoIdentifierProvided = "Nisu dani e-pošta/korisničko ime"
-croatianMessage InvalidEmailAddress = "Dana adresa e-pošte nije valjana"
-croatianMessage PasswordResetTitle = "Poništavanje lozinke"
-croatianMessage ProvideIdentifier = "E-pošta ili korisničko ime"
-croatianMessage SendPasswordResetEmail = "Pošalji e-poruku za poništavanje lozinke"
-croatianMessage (IdentifierNotFound ident) = "Korisničko ime/e-pošta nisu pronađeni: " <> ident
-croatianMessage Logout = "Odjava"
-croatianMessage LogoutTitle = "Odjava"
-croatianMessage AuthError = "Pogreška provjere autentičnosti"
-
-danishMessage :: AuthMessage -> Text
-danishMessage NoOpenID = "Mangler OpenID identifier"
-danishMessage LoginOpenID = "Login med OpenID"
-danishMessage LoginGoogle = "Login med Google"
-danishMessage LoginYahoo = "Login med Yahoo"
-danishMessage Email = "E-mail"
-danishMessage UserName = "Brugernavn"
-danishMessage Password = "Kodeord"
-danishMessage CurrentPassword = "Nuværende kodeord"
-danishMessage Register = "Opret"
-danishMessage RegisterLong = "Opret en ny konto"
-danishMessage EnterEmail = "Indtast din e-mailadresse nedenfor og en bekræftelsesmail vil blive sendt til dig."
-danishMessage ConfirmationEmailSentTitle = "Bekræftelsesmail sendt"
-danishMessage (ConfirmationEmailSent email) =
-    "En bekræftelsesmail er sendt til " `mappend`
-    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"
-danishMessage BadSetPass = "Du skal være logget ind for at sætte et kodeord"
-danishMessage SetPassTitle = "Sæt kodeord"
-danishMessage SetPass = "Sæt et nyt kodeord"
-danishMessage NewPass = "Nyt kodeord"
-danishMessage ConfirmPass = "Bekræft"
-danishMessage PassMismatch = "Kodeordne var forskellige, prøv venligst igen"
-danishMessage PassUpdated = "Kodeord opdateret"
-danishMessage Facebook = "Login med Facebook"
-danishMessage LoginViaEmail = "Login med e-mail"
-danishMessage InvalidLogin = "Ugyldigt login"
-danishMessage NowLoggedIn = "Du er nu logget ind"
-danishMessage LoginTitle = "Log ind"
-danishMessage PleaseProvideUsername = "Indtast venligst dit brugernavn"
-danishMessage PleaseProvidePassword = "Indtasy venligst dit kodeord"
-danishMessage NoIdentifierProvided = "Mangler e-mail/username"
-danishMessage InvalidEmailAddress = "Ugyldig e-mailadresse indtastet"
-danishMessage PasswordResetTitle = "Nulstilning af kodeord"
-danishMessage ProvideIdentifier = "E-mail eller brugernavn"
-danishMessage SendPasswordResetEmail = "Send kodeordsnulstillingsmail"
-danishMessage PasswordResetPrompt = "Indtast din e-mailadresse eller dit brugernavn nedenfor, så bliver en kodeordsnulstilningsmail sendt til dig."
-danishMessage InvalidUsernamePass = "Ugyldigt brugernavn/kodeord"
-danishMessage (IdentifierNotFound ident) = "Brugernavn findes ikke: " `mappend` ident
-danishMessage Logout = "Log ud"
-danishMessage LogoutTitle = "Log ud"
-danishMessage AuthError = "Fejl ved bekræftelse af identitet"
-
-koreanMessage :: AuthMessage -> Text
-koreanMessage NoOpenID = "OpenID ID가 없습니다"
-koreanMessage LoginOpenID = "OpenID로 로그인"
-koreanMessage LoginGoogle = "Google로 로그인"
-koreanMessage LoginYahoo = "Yahoo로 로그인"
-koreanMessage Email = "이메일"
-koreanMessage UserName = "사용자 이름"
-koreanMessage Password = "비밀번호"
-koreanMessage CurrentPassword = "현재 비밀번호"
-koreanMessage Register = "등록"
-koreanMessage RegisterLong = "새 계정 등록"
-koreanMessage EnterEmail = "이메일 주소를 아래에 입력하시면 확인 이메일이 발송됩니다."
-koreanMessage ConfirmationEmailSentTitle = "확인 이메일을 보냈습니다"
-koreanMessage (ConfirmationEmailSent email) =
-    "확인 이메일을 " `mappend`
-    email `mappend`
-    "에 보냈습니다."
-koreanMessage AddressVerified = "주소가 인증되었습니다. 새 비밀번호를 설정하세요."
-koreanMessage EmailVerifiedChangePass = "주소가 인증되었습니다. 새 비밀번호를 설정하세요."
-koreanMessage EmailVerified = "주소가 인증되었습니다"
-koreanMessage InvalidKeyTitle = "인증키가 잘못되었습니다"
-koreanMessage InvalidKey = "죄송합니다. 잘못된 인증키입니다."
-koreanMessage InvalidEmailPass = "이메일 주소나 비밀번호가 잘못되었습니다"
-koreanMessage BadSetPass = "비밀번호를 설정하기 위해서는 로그인해야 합니다"
-koreanMessage SetPassTitle = "비밀번호 설정"
-koreanMessage SetPass = "새 비밀번호 설정"
-koreanMessage NewPass = "새 비밀번호"
-koreanMessage ConfirmPass = "확인"
-koreanMessage PassMismatch = "비밀번호가 맞지 않습니다. 다시 시도해주세요."
-koreanMessage PassUpdated = "비밀번호가 업데이트 되었습니다"
-koreanMessage Facebook = "Facebook으로 로그인"
-koreanMessage LoginViaEmail = "이메일로"
-koreanMessage InvalidLogin = "잘못된 로그인입니다"
-koreanMessage NowLoggedIn = "로그인했습니다"
-koreanMessage LoginTitle = "로그인"
-koreanMessage PleaseProvideUsername = "사용자 이름을 입력하세요"
-koreanMessage PleaseProvidePassword = "비밀번호를 입력하세요"
-koreanMessage NoIdentifierProvided = "이메일 주소나 사용자 이름이 입력되어 있지 않습니다"
-koreanMessage InvalidEmailAddress = "이메일 주소가 잘못되었습니다"
-koreanMessage PasswordResetTitle = "비밀번호 변경"
-koreanMessage ProvideIdentifier = "이메일 주소나 사용자 이름"
-koreanMessage SendPasswordResetEmail = "비밀번호 재설정 이메일 보내기"
-koreanMessage PasswordResetPrompt = "이메일 주소나 사용자 이름을 아래에 입력하시면 비밀번호 재설정 이메일이 발송됩니다."
-koreanMessage InvalidUsernamePass = "사용자 이름이나 비밀번호가 잘못되었습니다"
-koreanMessage (IdentifierNotFound ident) = ident `mappend` "는 등록되어 있지 않습니다"
-koreanMessage Logout = "로그아웃"
-koreanMessage LogoutTitle = "로그아웃"
-koreanMessage AuthError = "인증오류"

yesod-auth/Yesod/Auth/OpenId.hs

@@ -1,9 +1,7 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE GADTs #-}
 module Yesod.Auth.OpenId
     ( authOpenId
     , forwardUrl
@@ -18,9 +16,10 @@ import qualified Web.Authenticate.OpenId as OpenId
 
 import Yesod.Form
 import Yesod.Core
+import Text.Cassius (cassius)
 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
@@ -53,6 +49,9 @@ authOpenId idType extensionFields =
 |] $ x `asTypeOf` y)
         [whamlet|
 $newline never
+<form method="get" action="@{tm forwardUrl}">
+    <input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id">
+    <button .openid-google>_{Msg.LoginGoogle}
 <form method="get" action="@{tm forwardUrl}">
     <input type="hidden" name="openid_identifier" value="http://me.yahoo.com">
     <button .openid-yahoo>_{Msg.LoginYahoo}
@@ -61,19 +60,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 +87,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
+    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 +108,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,7 +4,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 module Yesod.Auth.Routes where
 
 import Yesod.Core

yesod-auth/Yesod/Auth/Rpxnow.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
 module Yesod.Auth.Rpxnow
     ( authRpxnow
     ) where
@@ -12,16 +11,17 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow
 import Control.Monad (mplus)
 
 import Yesod.Core
+import Text.Hamlet (hamlet)
 import Data.Text (pack, unpack)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
 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 +33,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 +48,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/PasswordStore.hs

@@ -1,8 +1,13 @@
 {-# LANGUAGE OverloadedStrings, BangPatterns #-}
 {-# LANGUAGE CPP #-}
 -- |
--- This is a fork of pwstore-fast, originally copyright (c) Peter Scott, 2011,
+-- Module      : Crypto.PasswordStore
--- and released under a BSD-style licence.
+-- Copyright   : (c) Peter Scott, 2011
+-- License     : BSD-style
+--
+-- Maintainer  : pjscott@iastate.edu
+-- Stability   : experimental
+-- Portability : portable
 --
 -- Securely store hashed, salted passwords. If you need to store and verify
 -- passwords, there are many wrong ways to do it, most of them all too
@@ -33,7 +38,7 @@
 -- > >>> makePassword "hunter2" 14
 -- > "sha256|14|Zo4LdZGrv/HYNAUG3q8WcA==|zKjbHZoTpuPLp1lh6ATolWGIKjhXvY4TysuKvqtNFyk="
 --
--- This will hash the password @\"hunter2\"@, with strength 14, which is a good
+-- This will hash the password @\"hunter2\"@, with strength 12, which is a good
 -- default value. The strength here determines how long the hashing will
 -- take. When doing the hashing, we iterate the SHA256 hash function
 -- @2^strength@ times, so increasing the strength by 1 makes the hashing take
@@ -65,10 +70,8 @@
 -- Note that, as of version 2.4, you can also use PBKDF2, and specify the exact
 -- iteration count. This does not have a significant effect on security, but can
 -- be handy for compatibility with other code.
---
--- @since 1.4.18
 
-module Yesod.Auth.Util.PasswordStore (
+module Yesod.PasswordStore (
 
         -- * Algorithms
         pbkdf1,                 -- :: ByteString -> Salt -> Int -> ByteString
@@ -99,14 +102,16 @@ module Yesod.Auth.Util.PasswordStore (
         importSalt              -- :: ByteString -> Salt
   ) where
 
-import qualified Crypto.MAC.HMAC as CH
+
 import qualified Crypto.Hash as CH
+import qualified Crypto.Hash.SHA256 as H
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.Binary as Binary
 import Control.Monad
 import Control.Monad.ST
+import Data.Byteable (toBytes)
 import Data.STRef
 import Data.Bits
 import Data.ByteString.Char8 (ByteString)
@@ -115,7 +120,6 @@ import System.IO
 import System.Random
 import Data.Maybe
 import qualified Control.Exception
-import Data.ByteArray (convert)
 
 ---------------------
 -- Cryptographic base
@@ -128,23 +132,16 @@ import Data.ByteArray (convert)
 -- key should be stored in the password file. When a user wishes to authenticate
 -- a password, just pass it and the salt to this function, and see if the output
 -- matches.
---
--- @since 1.4.18
---
 pbkdf1 :: ByteString -> Salt -> Int -> ByteString
 pbkdf1 password (SaltBS salt) iter = hashRounds first_hash (iter + 1)
-  where
+    where first_hash = H.finalize $ H.init `H.update` password `H.update` salt
-    first_hash =
-      convert $
-      ((CH.hashFinalize $ CH.hashInit `CH.hashUpdate` password `CH.hashUpdate` salt) :: CH.Digest CH.SHA256)
-
 
 -- | Hash a 'ByteString' for a given number of rounds. The number of rounds is 0
 -- or more. If the number of rounds specified is 0, the ByteString will be
 -- returned unmodified.
 hashRounds :: ByteString -> Int -> ByteString
 hashRounds (!bs) 0 = bs
-hashRounds bs rounds = hashRounds (convert (CH.hash bs :: CH.Digest CH.SHA256)) (rounds - 1)
+hashRounds bs rounds = hashRounds (H.hash bs) (rounds - 1)
 
 -- | Computes the hmacSHA256 of the given message, with the given 'Salt'.
 hmacSHA256 :: ByteString
@@ -154,22 +151,19 @@ hmacSHA256 :: ByteString
            -> ByteString
            -- ^ The encoded message
 hmacSHA256 secret msg =
-    convert (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)
+    toBytes (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)
 
 -- | PBKDF2 key-derivation function.
 -- For details see @http://tools.ietf.org/html/rfc2898@.
 -- @32@ is the most common digest size for @SHA256@, and is
 -- what the algorithm internally uses.
 -- @HMAC+SHA256@ is used as @PRF@, because @HMAC+SHA1@ is considered too weak.
---
--- @since 1.4.18
---
 pbkdf2 :: ByteString -> Salt -> Int -> ByteString
 pbkdf2 password (SaltBS salt) c =
     let hLen = 32
         dkLen = hLen in go hLen dkLen
   where
-    go hLen dkLen | dkLen > (2^(32 :: Int) - 1) * hLen = error "Derived key too long."
+    go hLen dkLen | dkLen > (2^32 - 1) * hLen = error "Derived key too long."
                   | otherwise =
                       let !l = ceiling ((fromIntegral dkLen / fromIntegral hLen) :: Double)
                           !r = dkLen - (l - 1) * hLen
@@ -202,9 +196,6 @@ pbkdf2 password (SaltBS salt) c =
 -- | Generate a 'Salt' from 128 bits of data from @\/dev\/urandom@, with the
 -- system RNG as a fallback. This is the function used to generate salts by
 -- 'makePassword'.
---
--- @since 1.4.18
---
 genSaltIO :: IO Salt
 genSaltIO =
     Control.Exception.catch genSaltDevURandom def
@@ -258,9 +249,6 @@ writePwHash (strength, SaltBS salt, hash) =
 -- database. Generates a salt using high-quality randomness from
 -- @\/dev\/urandom@ or (if that is not available, for example on Windows)
 -- 'System.Random', which is included in the hashed output.
---
--- @since 1.4.18
---
 makePassword :: ByteString -> Int -> IO ByteString
 makePassword = makePasswordWith pbkdf1
 
@@ -269,8 +257,6 @@ makePassword = makePasswordWith pbkdf1
 --
 -- >>> makePasswordWith pbkdf1 "password" 14
 --
--- @since 1.4.18
---
 makePasswordWith :: (ByteString -> Salt -> Int -> ByteString)
                  -- ^ The algorithm to use (e.g. pbkdf1)
                  -> ByteString
@@ -287,9 +273,6 @@ makePasswordWith algorithm password strength = do
 -- Note that, unlike 'makePasswordWith', this function takes the @raw@
 -- number of iterations. This means the user will need to specify a
 -- sensible value, typically @10000@ or @20000@.
---
--- @since 1.4.18
---
 makePasswordSaltWith :: (ByteString -> Salt -> Int -> ByteString)
                      -- ^ A function modeling an algorithm (e.g. 'pbkdf1')
                      -> (Int -> Int)
@@ -310,9 +293,6 @@ makePasswordSaltWith algorithm strengthModifier pwd salt strength = writePwHash
 --
 -- > >>> makePasswordSalt "hunter2" (makeSalt "72cd18b5ebfe6e96") 14
 -- > "sha256|14|NzJjZDE4YjVlYmZlNmU5Ng==|yuiNrZW3KHX+pd0sWy9NTTsy5Yopmtx4UYscItSsoxc="
---
--- @since 1.4.18
---
 makePasswordSalt :: ByteString -> Salt -> Int -> ByteString
 makePasswordSalt = makePasswordSaltWith pbkdf1 (2^)
 
@@ -329,8 +309,6 @@ makePasswordSalt = makePasswordSaltWith pbkdf1 (2^)
 -- > >>> verifyPasswordWith pbkdf2 id "hunter2" "sha256..."
 -- > True
 --
--- @since 1.4.18
---
 verifyPasswordWith :: (ByteString -> Salt -> Int -> ByteString)
                    -- ^ A function modeling an algorithm (e.g. pbkdf1)
                    -> (Int -> Int)
@@ -347,9 +325,6 @@ verifyPasswordWith algorithm strengthModifier userInput pwHash =
           encode (algorithm userInput salt (strengthModifier strength)) == goodHash
 
 -- | Like 'verifyPasswordWith', but uses 'pbkdf1' as algorithm.
---
--- @since 1.4.18
---
 verifyPassword :: ByteString -> ByteString -> Bool
 verifyPassword = verifyPasswordWith pbkdf1 (2^)
 
@@ -363,9 +338,6 @@ verifyPassword = verifyPasswordWith pbkdf1 (2^)
 -- This function can be used to periodically update your password database when
 -- computers get faster, in order to keep up with Moore's law. This isn't hugely
 -- important, but it's a good idea.
---
--- @since 1.4.18
---
 strengthenPassword :: ByteString -> Int -> ByteString
 strengthenPassword pwHash newstr =
     case readPwHash pwHash of
@@ -380,9 +352,6 @@ strengthenPassword pwHash newstr =
                 hash = decodeLenient hashB64
 
 -- | Return the strength of a password hash.
---
--- @since 1.4.18
---
 passwordStrength :: ByteString -> Int
 passwordStrength pwHash = case readPwHash pwHash of
                             Nothing               -> 0
@@ -396,18 +365,12 @@ passwordStrength pwHash = case readPwHash pwHash of
 -- hash. You can generate a salt with 'genSaltIO' or 'genSaltRandom', or if you
 -- really know what you're doing, you can create them from your own ByteString
 -- values with 'makeSalt'.
---
--- @since 1.4.18
---
 newtype Salt = SaltBS ByteString
     deriving (Show, Eq, Ord)
 
 -- | Create a 'Salt' from a 'ByteString'. The input must be at least 8
 -- characters, and can contain arbitrary bytes. Most users will not need to use
 -- this function.
---
--- @since 1.4.18
---
 makeSalt :: ByteString -> Salt
 makeSalt = SaltBS . encode . check_length
     where check_length salt | B.length salt < 8 =
@@ -416,26 +379,17 @@ makeSalt = SaltBS . encode . check_length
 
 -- | Convert a 'Salt' into a 'ByteString'. The resulting 'ByteString' will be
 -- base64-encoded. Most users will not need to use this function.
---
--- @since 1.4.18
---
 exportSalt :: Salt -> ByteString
 exportSalt (SaltBS bs) = bs
 
 -- | Convert a raw 'ByteString' into a 'Salt'.
 -- Use this function with caution, since using a weak salt will result in a
 -- weak password.
---
--- @since 1.4.18
---
 importSalt :: ByteString -> Salt
 importSalt = SaltBS
 
 -- | Is the format of a password hash valid? Attempts to parse a given password
 -- hash. Returns 'True' if it parses correctly, and 'False' otherwise.
---
--- @since 1.4.18
---
 isPasswordFormatValid :: ByteString -> Bool
 isPasswordFormatValid = isJust . readPwHash
 
@@ -443,9 +397,6 @@ isPasswordFormatValid = isJust . readPwHash
 -- generator. Returns the salt and the updated random number generator. This is
 -- meant to be used with 'makePasswordSalt' by people who would prefer to either
 -- use their own random number generator or avoid the 'IO' monad.
---
--- @since 1.4.18
---
 genSaltRandom :: (RandomGen b) => b -> (Salt, b)
 genSaltRandom gen = (salt, newgen)
     where rands _ 0 = []
@@ -462,3 +413,17 @@ modifySTRef' ref f = do
     let x' = f x
     x' `seq` writeSTRef ref x'
 #endif
+
+#if MIN_VERSION_bytestring(0, 10, 0)
+toStrict :: BL.ByteString -> BS.ByteString
+toStrict = BL.toStrict
+
+fromStrict :: BS.ByteString -> BL.ByteString
+fromStrict = BL.fromStrict
+#else
+toStrict :: BL.ByteString -> BS.ByteString
+toStrict = BS.concat . BL.toChunks
+
+fromStrict :: BS.ByteString -> BL.ByteString
+fromStrict = BL.fromChunks . return
+#endif

yesod-auth/browserid.hs

@@ -26,7 +26,7 @@ mkYesod "BID" [parseRoutes|
 getRootR :: Handler ()
 getRootR = redirect $ AuthR LoginR
 
-getAfterLoginR :: Handler Html
+getAfterLoginR :: Handler RepHtml
 getAfterLoginR = do
     mauth <- maybeAuthId
     defaultLayout $ toWidget [hamlet|
@@ -41,14 +41,13 @@ instance YesodAuth BID where
     loginDest _ = AfterLoginR
     logoutDest _ = AuthR LoginR
     getAuthId = return . Just . credsIdent
-    authPlugins _ = [authBrowserId def]
+    authPlugins _ = [authBrowserId]
     authHttpManager = httpManager
-    maybeAuthId = lookupSession credsKey
 
 instance RenderMessage BID FormMessage where
     renderMessage _ _ = defaultFormMessage
 
 main :: IO ()
 main = do
-    m <- newManager conduitManagerSettings
+    m <- newManager def
     toWaiApp (BID m) >>= run 3000 . logStdoutDev

yesod-auth/openid.hs

@@ -27,7 +27,7 @@ getRootR = getAfterLoginR
 getAfterLoginR :: Handler RepHtml
 getAfterLoginR = do
     mauth <- maybeAuthId
-    defaultLayout [whamlet|
+    defaultLayout $ addHamlet [hamlet|
 <p>Auth: #{show mauth}
 $maybe _ <- mauth
     <p>
@@ -38,22 +38,21 @@ $nothing
 |]
 
 instance Yesod BID where
-    approot = guessApproot
+    approot = ApprootStatic "http://localhost:3000"
 
 instance YesodAuth BID where
     type AuthId BID = Text
     loginDest _ = AfterLoginR
     logoutDest _ = AuthR LoginR
     getAuthId = return . Just . credsIdentClaimed
-    authPlugins _ = [authOpenId Claimed []]
+    authPlugins _ = [authOpenId]
     authHttpManager = httpManager
-    maybeAuthId = lookupSession credsKey
 
 instance RenderMessage BID FormMessage where
     renderMessage _ _ = defaultFormMessage
 
 main :: IO ()
 main = do
-    m <- newManager tlsManagerSettings
+    m <- newManager def
     toWaiApp (BID m) >>= run 3000
 

yesod-auth/yesod-auth.cabal

@@ -1,6 +1,5 @@
-cabal-version:   >=1.10
 name:            yesod-auth
-version:         1.6.11.2
+version:         1.3.1.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -8,61 +7,63 @@ 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>
+description:
+    This package provides a pluggable mechanism for allowing users to authenticate with your site. It comes with a number of common plugins, such as OpenID, 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.
+   .
+   * <http://hackage.haskell.org/package/yesod-auth-account>: An account authentication plugin for Yesod
+   .
+   * <http://hackage.haskell.org/package/yesod-auth-hashdb>: The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security.
+   .
+   * <https://github.com/ollieh/yesod-auth-bcrypt/>: An alternative to the HashDB module.
 extra-source-files: persona_sign_in_blue.png
-                    README.md
-                    ChangeLog.md
-
-flag network-uri
-  description: Get Network.URI from the network-uri package
-  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.2       && < 1.3
-                   , authenticate            >= 1.3.4
+                   , wai                     >= 1.4
+                   , template-haskell
                    , base16-bytestring
-                   , base64-bytestring
+                   , cryptohash
-                   , binary
+                   , random                  >= 1.0.0.2
-                   , blaze-builder
+                   , text                    >= 0.7
+                   , mime-mail               >= 0.3
+                   , yesod-persistent        >= 1.2
+                   , hamlet                  >= 1.1
+                   , shakespeare
+                   , shakespeare-css         >= 1.0
+                   , shakespeare-js          >= 1.0.2
+                   , containers
+                   , unordered-containers
+                   , yesod-form              >= 1.3       && < 1.4
+                   , transformers            >= 0.2.2
+                   , persistent              >= 1.2       && < 1.4
+                   , persistent-template     >= 1.2       && < 1.4
+                   , http-conduit            >= 1.5
+                   , aeson                   >= 0.5
+                   , lifted-base             >= 0.1
                    , blaze-html              >= 0.5
                    , blaze-markup            >= 0.5.1
-                   , bytestring              >= 0.9.1.4
+                   , network
-                   , 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
+                   , attoparsec-conduit
-
-    if flag(network-uri)
-      build-depends: network-uri >= 2.6
 
     exposed-modules: Yesod.Auth
                      Yesod.Auth.BrowserId
@@ -71,10 +72,10 @@ library
                      Yesod.Auth.OpenId
                      Yesod.Auth.Rpxnow
                      Yesod.Auth.Message
+                     Yesod.Auth.GoogleEmail
                      Yesod.Auth.GoogleEmail2
-                     Yesod.Auth.Hardcoded
-                     Yesod.Auth.Util.PasswordStore
     other-modules:   Yesod.Auth.Routes
+                     Yesod.PasswordStore
     ghc-options:     -Wall
 
 source-repository head

yesod-bin/AddHandler.hs

@@ -1,168 +1,64 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
 module AddHandler (addHandler) where
 
 import Prelude hiding (readFile)
-import System.IO  (hFlush, stdout)
+import System.IO (hFlush, stdout)
-import Data.Char  (isLower, toLower, isSpace)
+import Data.Char (isLower, toLower, isSpace)
-import Data.List  (isPrefixOf, isSuffixOf, stripPrefix)
+import Data.List (isPrefixOf, isSuffixOf)
-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 System.Directory (getDirectoryContents)
-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)
-import System.Directory (getDirectoryContents, doesFileExist)
-import Control.Monad (unless)
-
-data RouteError = EmptyRoute
-                | RouteCaseError
-                | RouteExists FilePath
-                deriving Eq
-
-instance Show RouteError where
-    show EmptyRoute         = "No name entered. Quitting ..."
-    show RouteCaseError     = "Name must start with an upper case letter"
-    show (RouteExists file) = "File already exists: " ++ file
 
 -- strict readFile
 readFile :: FilePath -> IO String
 readFile = fmap T.unpack . TIO.readFile
 
-cmdLineArgsError :: String
+addHandler :: IO ()
-cmdLineArgsError = "You have to specify a route name if you want to add handler with command line arguments."
+addHandler = do
+    allFiles <- getDirectoryContents "."
+    cabal <-
+        case filter (".cabal" `isSuffixOf`) allFiles of
+            [x] -> return x
+            [] -> error "No cabal file found"
+            _ -> error "Too many cabal files found"
 
-addHandler :: Maybe String -> Maybe String -> [String] -> IO ()
+    putStr "Name of route (without trailing R): "
-addHandler (Just route) pat met = do
+    hFlush stdout
-    cabal <- getCabal
+    name <- getLine
-    checked <- checkRoute route cabal
+    case name of
-    let routePair = case checked of
+        [] -> error "Please provide a name"
-          Left err@EmptyRoute -> (error . show) err
+        c:_
-          Left err@RouteCaseError -> (error . show) err
+            | isLower c -> error "Name must start with an upper case letter"
-          Left err@(RouteExists _) -> (error . show) err
+            | otherwise -> return ()
-          Right p -> p
-
-    addHandlerFiles cabal routePair pattern methods
-  where
-    pattern = fromMaybe "" pat -- pattern defaults to ""
-    methods = unwords met      -- methods default to none
-
-addHandler Nothing (Just _) _ = error cmdLineArgsError
-addHandler Nothing _ (_:_)    = error cmdLineArgsError
-addHandler _ _ _ = addHandlerInteractive
-
-addHandlerInteractive :: IO ()
-addHandlerInteractive = do
-    cabal <- getCabal
-    let routeInput = do
-          putStr "Name of route (without trailing R): "
-          hFlush stdout
-          name <- getLine
-          checked <- checkRoute name cabal
-          case checked of
-              Left err@EmptyRoute -> (error . show) err
-              Left err@RouteCaseError -> print err >> routeInput
-              Left err@(RouteExists _) -> do
-                print err
-                putStrLn "Try another name or leave blank to exit"
-                routeInput
-              Right p -> return p
-
-    routePair <- routeInput
     putStr "Enter route pattern (ex: /entry/#EntryId): "
     hFlush stdout
     pattern <- getLine
     putStr "Enter space-separated list of methods (ex: GET POST): "
     hFlush stdout
     methods <- getLine
-    addHandlerFiles cabal routePair pattern methods
 
-getRoutesFilePath :: IO FilePath
+    let modify fp f = readFile fp >>= writeFile fp . f
-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 ()
+    modify "Application.hs" $ fixApp name
-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 ("Handler/" ++ name ++ ".hs") $ mkHandler name pattern methods
-    writeFile handlerFile $ mkHandler name pattern methods
-    specExists <- doesFileExist specFile
-    unless specExists $
-      writeFile specFile $ mkSpec name pattern methods
-  where
-    specFile = "test/Handler/" ++ name ++ "Spec.hs"
-    modify fp f = readFile fp >>= writeFile fp . f
-
-getCabal :: IO FilePath
-getCabal = do
-    allFiles <- getDirectoryContents "."
-    case filter (".cabal" `isSuffixOf`) allFiles of
-        [x] -> return x
-        [] -> error "No cabal file found"
-        _ -> error "Too many cabal files found"
-
-checkRoute :: String -> FilePath -> IO (Either RouteError (String, FilePath))
-checkRoute name cabal =
-    case name of
-        [] -> return $ Left EmptyRoute
-        c:_
-            | isLower c -> return $ Left RouteCaseError
-            | otherwise -> do
-                -- Check that the handler file doesn't already exist
-                src <- getSrcDir cabal
-                let handlerFile = concat [src, "/Handler/", name, ".hs"]
-                exists <- doesFileExist handlerFile
-                if exists
-                    then (return . Left . RouteExists) handlerFile
-                    else return $ Right (name, handlerFile)
 
 fixApp :: String -> String -> String
 fixApp name =
     unlines . reverse . go . reverse . lines
   where
-    l spaces = "import " ++ spaces ++ "Handler." ++ name
+    l = "import Handler." ++ name
 
-    go [] = [l ""]
+    go [] = [l]
     go (x:xs)
-        | Just y <- stripPrefix "import " x, "Handler." `isPrefixOf` dropWhile (== ' ') y = l (takeWhile (== ' ') y) : x : xs
+        | "import Handler." `isPrefixOf` x = l : x : xs
         | otherwise = x : go xs
 
 fixCabal :: String -> String -> String
-fixCabal name orig =
+fixCabal name =
-    unlines $ (reverse $ go $ reverse libraryLines) ++ restLines
+    unlines . reverse . go . reverse . lines
   where
-    origLines = lines orig
+    l = "import Handler." ++ name
-
-    (libraryLines, restLines) = break isExeTestBench origLines
-
-    isExeTestBench x = any
-        (\prefix -> prefix `isPrefixOf` x)
-        [ "executable"
-        , "test-suite"
-        , "benchmark"
-        ]
-
-    l = "                  Handler." ++ name
 
     go [] = [l]
     go (x:xs)
@@ -172,37 +68,17 @@ fixCabal name orig =
         (spaces, x') = span isSpace x
 
 fixRoutes :: String -> String -> String -> String -> String
-fixRoutes name pattern methods fileContents =
+fixRoutes name pattern methods =
-    fileContents ++ l
+    (++ l)
   where
     l = concat
-        [ startingCharacter
+        [ pattern
-        , pattern
         , " "
         , name
         , "R "
         , methods
         , "\n"
         ]
-    startingCharacter = if "\n" `isSuffixOf` fileContents then "" else "\n"
-
-mkSpec :: String -> String -> String -> String
-mkSpec name _ methods = unlines
-    $ ("module Handler." ++ name ++ "Spec (spec) where")
-    : ""
-    : "import TestImport"
-    : ""
-    : "spec :: Spec"
-    : "spec = withApp $ do"
-    : concatMap go (words methods)
-  where
-    go method =
-        [ ""
-        , "    describe \"" ++ func ++ "\" $ do"
-        , "        error \"Spec not implemented: " ++ func ++ "\""
-        , ""]
-      where
-        func = concat [map toLower method, name, "R"]
 
 mkHandler :: String -> String -> String -> String
 mkHandler name pattern methods = unlines
@@ -216,9 +92,7 @@ mkHandler name pattern methods = unlines
         , concat $ func : " :: " : map toArrow types ++ ["Handler Html"]
         , concat
             [ func
-            , " "
+            , " = error \"Not yet implemented: "
-            , concatMap toArgument types
-            , "= error \"Not yet implemented: "
             , func
             , "\""
             ]
@@ -229,7 +103,6 @@ mkHandler name pattern methods = unlines
     types = getTypes pattern
 
     toArrow t = concat [t, " -> "]
-    toArgument t = concat [uncapitalize t, " "]
 
     getTypes "" = []
     getTypes ('/':rest) = getTypes rest
@@ -238,22 +111,3 @@ mkHandler name pattern methods = unlines
       where
         (typ, rest') = break (== '/') rest
     getTypes rest = getTypes $ dropWhile (/= '/') rest
-
-uncapitalize :: String -> String
-uncapitalize (x:xs) = toLower x : xs
-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,263 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Build
+    ( getDeps
+    , touchDeps
+    , touch
+    , recompDeps
+    , isNewerThan
+    , safeReadFile
+    ) where
+
+import           Control.Applicative ((<|>), 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 (mappend, mempty))
+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)
+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 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" </> 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" </> replaceExtension hs "hi"
+
+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) <$> 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,279 +0,0 @@
-# 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
-
-## 1.5.2.5
-
-* Support for `add-handler` when modules are in `src/` directory [#1413](https://github.com/yesodweb/yesod/issues/1413)
-
-## 1.5.2.4
-
-* Cabal 2.0 support
-
-## 1.5.2.3
-
-* Fix race condition which leads dev server to stay in compilation mode. [#1380](https://github.com/yesodweb/yesod/issues/1380)
-
-## 1.5.2.2
-
-* I guess `--no-nix-pure` implies Nix... sigh [#1359](https://github.com/yesodweb/yesod/issues/1359)
-
-## 1.5.2.1
-
-* Use `--no-nix-pure` [#1357](https://github.com/yesodweb/yesod/issues/1357)
-
-## 1.5.2
-
-* Fix warnings
-
-## 1.5.1
-
-* Add `--host` option to `yesod devel`
-
-## 1.5.0.1
-
-* Fix build failure
-
-## 1.5.0
-
-Rewrite of `yesod devel` to take advantage of Stack for a simpler codebase.
-
-Advantages:
-
-* Does not link against the ghc library, so can be used with multiple
-  GHC versions
-* Leverages Stack's ability to check for dependent files, which is
-  more robust than what yesod devel was doing previously
-* Seems to involve less rebuilding of the library on initial run
-
-Disadvantages:
-
-* Lost some functionality (e.g., failure hooks, controlling the exit
-  command)
-* Newer codebase, quite likely has bugs that need to be ironed out.
-
-## 1.4.18.7
-
-* Actually release the changes for #1284
-
-## 1.4.18.6
-
-* Fix support for GHC 8.0.1 [#1284](https://github.com/yesodweb/yesod/issues/1284)
-
-## 1.4.18.5
-
-* yesod-bin: Make it build with latest optparse-applicative [#1282](https://github.com/yesodweb/yesod/pull/1282)
-
-## 1.4.18.4
-
-* Link yesod-bin with wxneeded on OpenBSD. [#1281](https://github.com/yesodweb/yesod/pull/1281)
-
-## 1.4.18.3
-
-* Adding a new handler adds it under wrong stanza [#1273](https://github.com/yesodweb/yesod/issues/1273)
-
-## 1.4.18.2
-
-* Work around change in behavior in newer optparse-applicative ([mailing list discussion](https://groups.google.com/d/msg/yesodweb/BrTkMKFREgU/AKVc9AK2AQAJ))
-
-## 1.4.18.1
-
-* error handling when checking for stack binary [#1219](https://github.com/yesodweb/yesod/pull/1219)
-* GHC 8 support
-
-## 1.4.18
-
-* Disable `yesod test` when using Stack [#1198](https://github.com/yesodweb/yesod/issues/1198)
-
-## 1.4.17
-
-* Fully remove the `yesod init` command
-
-## 1.4.16.1
-
-* Workaround for [wai#478](https://github.com/yesodweb/wai/issues/478)
-
-## 1.4.16
-
-* Some updates for better reverse proxying [yesod-scaffold#114](https://github.com/yesodweb/yesod-scaffold/issues/114)
-
-## 1.4.15
-
-* Deprecate yesod init
-
-## 1.4.14
-
-* Fix order of -package-db arguments to runghc [#1057](https://github.com/yesodweb/yesod/issues/1057)
-
-## 1.4.13
-
-* Enable stack with yesod keter [#1041](https://github.com/yesodweb/yesod/pull/1041)
-
-## 1.4.12
-
-* Devel server: have to type quit to quit
-
-## 1.4.11
-
-* Add support to `yesod devel` to detect and use `GHC_PACKAGE_PATH`. This makes
-  `yesod devel` compatible with `stack`, just run: `stack exec -- yesod devel`.
-
-## 1.4.10
-
-* Scaffolding update
-
-## 1.4.9.2
-
-* Collapse paths in keter bundles, see [mailing list thread](https://groups.google.com/d/msg/yesodweb/Ndd310qfSEc/pZOXldsKowsJ)
-
-## 1.4.9
-
-* Command line options for `yesod init` [#986](https://github.com/yesodweb/yesod/pull/986)
-
-## 1.4.8
-
-* Drop system-filepath
-
-## 1.4.7.2
-
-* Scaffolding updates, including fix for [#982](https://github.com/yesodweb/yesod/issues/982)
-
-## 1.4.7
-
-* GHC 7.10 support
-
-## 1.4.6
-
-* Add TLS support to `yesod devel` [#964](https://github.com/yesodweb/yesod/pull/964)
-
-## 1.4.5
-
-* add a switch to yesod to skip deploying a .keter with copy-to [#952](https://github.com/yesodweb/yesod/issues/952)
-
-## 1.4.4
-
-* Add and process Keter option 'extraFiles' [#947](https://github.com/yesodweb/yesod/pull/947)
-
-## 1.4.3.11
-
-* Disregard proxy environment variables in yesod devel [#945](https://github.com/yesodweb/yesod/pull/945)
-
-## 1.4.3.10
-
-* Allow blaze-builder 0.4
-
-## 1.4.3.9
-
-* Scaffold update: minimal scaffold uses yesod-core instead of yesod [yesodweb/yesod-scaffold#65](https://github.com/yesodweb/yesod-scaffold/issues/65)
-
-## 1.4.3.8
-
-* Scaffold update: fix 404 for missing sourcemap
-
-## 1.4.3.6
-
-* Scaffold update: use `addToken` instead of `addNonce`
-
-## 1.4.3.5
-
-* Fix add-handler putting two routes on one line [#922](https://github.com/yesodweb/yesod/pull/922)
-
-## 1.4.3.4
-
-Scaffolding updates:
-
-* Improve `DevelMain` support
-* Wipe out database during test runs
-* Convenience `unsafeHandler` function
-* Remove deprecated Chrome Frame code
-
-## 1.4.3.3
-
-More consistent whitespace in hamlet files in scaffolding [#50](https://github.com/yesodweb/yesod-scaffold/issues/50)
-
-## 1.4.3.2
-
-add-handler adds arguments too [#898](https://github.com/yesodweb/yesod/issues/898)
-
-## 1.4.3
-
-Add the minimal scaffolding
-
-## 1.4.2
-
-Scaffolding updates:
-
-* Import.NoFoundation
-* Explanation of static files in Settings.StaticFiles
-* Explanation of environment variables in settings.yml
-
-## 1.4.1.2
-
-No args passed in keter.yml
-
-## 1.4.1
-
-Significant update to the scaffolding.
-
-## 1.4.0.9
-
-Allow devel.hs to be located in app/ or src/ subdirectories.
-
-## 1.4.0.8
-
-Updated postgres-fay scaffolding for yesod-fay 0.7.0
-
-## 1.4.0.7
-
-Fix a bug in `yesod devel` when cabal config has `tests: True` #864

yesod-bin/Devel.hs

@@ -1,145 +1,141 @@
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell   #-}
 module Devel
     ( devel
-    , develSignal
     , DevelOpts(..)
+    , DevelTermOpt(..)
+    , defaultDevelOpts
     ) where
 
-import           Control.Applicative                   ((<|>))
+import qualified Distribution.Compiler                 as D
-import           UnliftIO                              (race_)
+import qualified Distribution.ModuleName               as D
-import           Control.Concurrent                    (threadDelay)
-import           Control.Concurrent.STM
-import qualified UnliftIO.Exception                    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.FileEmbed                        (embedFile)
-import qualified Data.Map                              as Map
-import           Data.Maybe                            (isJust)
-import qualified Data.Set                              as Set
-import           Data.Streaming.Network                (bindPortTCP,
-                                                        bindRandomPortTCP)
-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.Configure         as D
+import qualified Distribution.Simple.Program           as D
 import qualified Distribution.Simple.Utils             as D
 import qualified Distribution.Verbosity                as D
-import           Network.HTTP.Client                   (newManager)
+
-import           Network.HTTP.Client                   (managerSetProxy,
+import           Control.Applicative                   ((<$>), (<*>))
-                                                        noProxy)
+import           Control.Concurrent                    (forkIO, threadDelay)
-import           Network.HTTP.Client.TLS               (tlsManagerSettings)
+import           Control.Concurrent.MVar               (MVar, newEmptyMVar,
-import           Network.HTTP.ReverseProxy             (ProxyDest (ProxyDest),
+                                                        takeMVar, tryPutMVar)
-                                                        waiProxyToSettings,
+import qualified Control.Exception                     as Ex
-                                                        wpsOnExc, wpsTimeout,
+import           Control.Monad                         (forever, unless, void,
-#if MIN_VERSION_http_reverse_proxy(0, 6, 0)
+                                                        when, forM)
-                                                        defaultWaiProxySettings
+import           Control.Monad.IO.Class                (liftIO)
-#else
+import           Control.Monad.Trans.State             (evalStateT, get)
-                                                        def
+import qualified Data.IORef                            as I
-#endif
+
-                                                        )
+import qualified Data.ByteString.Lazy                  as LB
-import qualified Network.HTTP.ReverseProxy             as ReverseProxy
+import           Data.Char                             (isNumber, isUpper)
-import           Network.HTTP.Types                    (status200, status503)
+import qualified Data.List                             as L
-import qualified Network.Socket
+import qualified Data.Map                              as Map
-import           Network.Wai                           (requestHeaderHost,
+import           Data.Maybe                            (fromMaybe)
-                                                        requestHeaders,
+import qualified Data.Set                              as Set
-                                                        responseLBS)
+
-import           Network.Wai.Handler.Warp              (defaultSettings, runSettings,
-                                                        setPort, setHost)
-import           Network.Wai.Handler.WarpTLS           (runTLS, tlsSettings,
-                                                        tlsSettingsMemory)
-import           Network.Wai.Parse                     (parseHttpAccept)
-import           Say
 import           System.Directory
-import           System.Environment                    (getEnvironment,
+import           System.Environment                    (getEnvironment)
-                                                        getExecutablePath)
+import           System.Exit                           (ExitCode (..),
-import           System.FilePath                       (takeDirectory,
+                                                        exitFailure,
-                                                        takeFileName, (</>))
+                                                        exitSuccess)
+import           System.FilePath                       (dropExtension,
+                                                        splitDirectories,
+                                                        takeExtension, (</>))
 import           System.FSNotify
-import           System.IO                             (stdout, stderr)
+import           System.IO                             (Handle)
 import           System.IO.Error                       (isDoesNotExistError)
-import           Data.Conduit.Process.Typed
+import           System.Posix.Types                    (EpochTime)
+import           System.PosixCompat.Files              (getFileStatus,
+                                                        modificationTime)
+import           System.Process                        (ProcessHandle,
+                                                        createProcess, env,
+                                                        getProcessExitCode,
+                                                        proc, readProcess,
+                                                        system,
+                                                        terminateProcess)
+import           System.Timeout                        (timeout)
 
--- We have two special files:
+import           Build                                 (getDeps, isNewerThan,
---
+                                                        recompDeps)
--- * The terminate file tells the child process to die simply by being
+import           GhcBuild                              (buildPackage,
--- present. Ideally we'd handle this via killing the process
+                                                        getBuildFlags, getPackageArgs)
--- directly, but that's historically never worked reliably.
---
--- * The signal file, which tells us that "stack build" has succeeded
--- yet again.
-data SpecialFile = TermFile | SignalFile
 
-specialFilePath :: SpecialFile -> FilePath
+import qualified Config                                as GHC
+import           Data.Streaming.Network                (bindPortTCP)
+import           Network                               (withSocketsDo)
+#if MIN_VERSION_http_conduit(2, 0, 0)
+import           Network.HTTP.Conduit                  (conduitManagerSettings, newManager)
+import           Data.Default.Class                    (def)
+#else
+import           Network.HTTP.Conduit                  (def, newManager)
+#endif
+import           Network.HTTP.ReverseProxy             (ProxyDest (ProxyDest),
+                                                        waiProxyToSettings, wpsTimeout, wpsOnExc)
+#if MIN_VERSION_http_reverse_proxy(0, 2, 0)
+import qualified Network.HTTP.ReverseProxy             as ReverseProxy
+#endif
+import           Network.HTTP.Types                    (status200, status503)
+import           Network.Socket                        (sClose)
+import           Network.Wai                           (responseLBS, requestHeaders)
+import           Network.Wai.Parse                     (parseHttpAccept)
+import           Network.Wai.Handler.Warp              (run)
+import           SrcLoc                                (Located)
+import           Data.FileEmbed        (embedFile)
 
--- used by scaffolded app, cannot change
+lockFile :: DevelOpts -> FilePath
-specialFilePath TermFile = "yesod-devel/devel-terminate"
+lockFile _opts =  "yesod-devel/devel-terminate"
 
--- only used internally, can change
+writeLock :: DevelOpts -> IO ()
-specialFilePath SignalFile = "yesod-devel/rebuild"
+writeLock opts = do
+    createDirectoryIfMissing True "yesod-devel"
+    writeFile (lockFile opts) ""
+    createDirectoryIfMissing True "dist" -- for compatibility with old devel.hs
+    writeFile "dist/devel-terminate" ""
 
--- | Write a special file
+removeLock :: DevelOpts -> IO ()
-writeSpecialFile :: SpecialFile -> IO ()
+removeLock opts = do
-writeSpecialFile sp = do
+    removeFileIfExists (lockFile opts)
-    let fp = specialFilePath sp
+    removeFileIfExists "dist/devel-terminate"  -- for compatibility with old devel.hs
-    createDirectoryIfMissing True $ takeDirectory fp
-    now <- getCurrentTime
-    writeFile fp $ show now
 
--- | Remove a special file
+data DevelTermOpt = TerminateOnEnter | TerminateOnlyInterrupt
-removeSpecialFile :: SpecialFile -> IO ()
+     deriving (Show, Eq)
-removeSpecialFile sp = removeFile (specialFilePath sp) `Ex.catch` \e ->
-  if isDoesNotExistError e
-    then return ()
-    else Ex.throwIO e
-
--- | Get an absolute path to the special file
-canonicalizeSpecialFile :: SpecialFile -> IO FilePath
-canonicalizeSpecialFile sp = do
-    let fp = specialFilePath sp
-        dir = takeDirectory fp
-        file = takeFileName fp
-    createDirectoryIfMissing True dir
-    dir' <- canonicalizePath dir
-    return $ dir' </> file
-
--- | Used as a callback from "stack build --exec" to write the signal file
-develSignal :: IO ()
-develSignal = writeSpecialFile SignalFile
-
--- | Options to be provided on the command line
 data DevelOpts = DevelOpts
-      { verbose         :: Bool
+      { isCabalDev   :: Bool
-      , successHook     :: Maybe String
+      , forceCabal   :: Bool
-      , develPort       :: Int
+      , verbose      :: Bool
-      , develTlsPort    :: Int
+      , eventTimeout :: Int -- negative value for no timeout
-      , proxyTimeout    :: Int
+      , successHook  :: Maybe String
+      , failHook     :: Maybe String
+      , buildDir     :: Maybe String
+      , develPort    :: Int
+      , proxyTimeout :: Int
       , useReverseProxy :: Bool
-      , develHost       :: Maybe String
+      , terminateWith :: DevelTermOpt
-      , cert            :: Maybe (FilePath, FilePath)
       } deriving (Show, Eq)
 
--- | Run a reverse proxy from the develPort and develTlsPort ports to
+getBuildDir :: DevelOpts -> String
--- the app running in appPortVar. If there is no response on the
+getBuildDir opts = fromMaybe "dist" (buildDir opts)
--- application port, give an appropriate message to the user.
+
-reverseProxy :: DevelOpts -> TVar Int -> IO ()
+defaultDevelOpts :: DevelOpts
-reverseProxy opts appPortVar = do
+defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing 3000 10 True TerminateOnEnter
-    manager <- newManager $ managerSetProxy noProxy tlsManagerSettings
+
-    let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")]
+cabalProgram :: DevelOpts -> FilePath
-        sayV = when (verbose opts) . sayString
+cabalProgram opts | isCabalDev opts = "cabal-dev"
+                  | otherwise       = "cabal"
+
+-- | Run a reverse proxy from port 3000 to 3001. If there is no response on
+-- 3001, give an appropriate message to the user.
+reverseProxy :: DevelOpts -> I.IORef Int -> IO ()
+reverseProxy opts iappPort = do
+#if MIN_VERSION_http_conduit(2, 0, 0)
+    manager <- newManager conduitManagerSettings
+#else
+    manager <- newManager def
+#endif
+    let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html")
     let onExc _ req
             | maybe False (("application/json" `elem`) . parseHttpAccept)
                 (lookup "accept" $ requestHeaders req) =
@@ -153,381 +149,346 @@ reverseProxy opts appPortVar = do
                 ]
                 refreshHtml
 
-    let proxyApp = waiProxyToSettings
+    let runProxy =
+            run (develPort opts) $ waiProxyToSettings
                 (const $ do
-                    appPort <- atomically $ readTVar appPortVar
+                    appPort <- liftIO $ I.readIORef iappPort
-                    sayV $ "revProxy: appPort " ++ (show appPort)
                     return $
+#if MIN_VERSION_http_reverse_proxy(0, 2, 0)
                         ReverseProxy.WPRProxyDest
-                        $ ProxyDest "127.0.0.1" appPort)
-#if MIN_VERSION_http_reverse_proxy(0, 6, 0)
-                defaultWaiProxySettings
 #else
-                def
+                        Right
 #endif
+                        $ ProxyDest "127.0.0.1" appPort)
+                def
+#if MIN_VERSION_wai(3, 0, 0)
                     { wpsOnExc = \e req f -> onExc e req >>= f
+#else
+                    { wpsOnExc = onExc
+#endif
                     , wpsTimeout =
                         if proxyTimeout opts == 0
                             then Nothing
                             else Just (1000000 * proxyTimeout opts)
                     }
                 manager
-        defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings
+    loop runProxy `Ex.onException` exitFailure
-        runProxyTls port app = do
+  where
-          let certDef = $(embedFile "certificate.pem")
+    loop proxy = forever $ do
-              keyDef = $(embedFile "key.pem")
+        void proxy
-              theSettings = case cert opts of
+        putStrLn "Reverse proxy stopped, but it shouldn't"
-                Nothing -> tlsSettingsMemory certDef keyDef
+        threadDelay 1000000
-                Just (c,k) -> tlsSettings c k
+        putStrLn "Restarting reverse proxy"
-          runTLS theSettings (setPort port defaultSettings') $ \req send -> do
-            let req' = req
-                    { requestHeaders
-                        = ("X-Forwarded-Proto", "https")
-                        -- Workaround for
-                        -- https://github.com/yesodweb/wai/issues/478, where
-                        -- the Host headers aren't set. Without this, generated
-                        -- URLs from guestApproot are incorrect, see:
-                        -- https://github.com/yesodweb/yesod-scaffold/issues/114
-                        : (case lookup "host" (requestHeaders req) of
-                            Nothing ->
-                                case requestHeaderHost req of
-                                    Just host -> (("Host", host):)
-                                    Nothing -> id
-                            Just _ -> id)
-                          (requestHeaders req)
-                    }
-            app req' send
-        httpProxy = runSettings (setPort (develPort opts) defaultSettings') proxyApp
-        httpsProxy = runProxyTls (develTlsPort opts) proxyApp
-    say "Application can be accessed at:\n"
-    sayString $ "http://localhost:" ++ show (develPort opts)
-    sayString $ "https://localhost:" ++ show (develTlsPort opts)
-    say $ "If you wish to test https capabilities, you should set the following variable:"
-    sayString $ "  export APPROOT=https://localhost:" ++ show (develTlsPort opts)
-    say ""
-    race_ httpProxy httpsProxy
 
--- | Check if the given port is available.
 checkPort :: Int -> IO Bool
 checkPort p = do
-    es <- Ex.tryIO $ bindPortTCP p "*4"
+    es <- Ex.try $ bindPortTCP p "*4"
     case es of
-        Left _ -> return False
+        Left (_ :: Ex.IOException) -> return False
         Right s -> do
-            Network.Socket.close s
+            sClose s
             return True
 
--- | Get a random, unused port.
+getPort :: DevelOpts -> Int -> IO Int
-getNewPort :: DevelOpts -> IO Int
+getPort opts _ | not (useReverseProxy opts) = return $ develPort opts
-getNewPort opts = do
+getPort _ p0 =
-    (port, socket) <- bindRandomPortTCP "*"
+    loop p0
-    when (verbose opts) $ sayString $ "Got new port: " ++ show port
+  where
-    Network.Socket.close socket
+    loop p = do
-    return port
+        avail <- checkPort p
+        if avail then return p else loop (succ p)
 
--- | Utility function
 unlessM :: Monad m => m Bool -> m () -> m ()
 unlessM c a = c >>= \res -> unless res a
 
--- | Find the file containing the devel code to be run.
+devel :: DevelOpts -> [String] -> IO ()
-checkDevelFile :: IO FilePath
+devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
-checkDevelFile =
-    loop paths
-  where
-    paths = ["app/devel.hs", "devel.hs", "src/devel.hs"]
-
-    loop [] = error $ "file devel.hs not found, checked: " ++ show paths
-    loop (x:xs) = do
-        e <- doesFileExist x
-        if e
-            then return x
-            else loop xs
-
-stackSuccessString :: ByteString
-stackSuccessString = "ExitSuccess"
-
-stackFailureString :: ByteString
-stackFailureString = "ExitFailure"
-
--- We need updateAppPort logic to prevent a race condition.
--- See https://github.com/yesodweb/yesod/issues/1380
-updateAppPort :: ByteString -> TVar Bool -- ^ Bool to indicate if the
-                                         -- output from stack has
-                                         -- started. False indicate
-                                         -- that it hasn't started
-                                         -- yet.
-              -> TVar Int -> STM ()
-updateAppPort bs buildStarted appPortVar = do
-  hasStarted <- readTVar buildStarted
-  let buildEnd = isInfixOf stackFailureString bs || isInfixOf stackSuccessString bs
-  case (hasStarted, buildEnd) of
-    (False, False) -> do
-      writeTVar appPortVar (-1 :: Int)
-      writeTVar buildStarted True
-    (True, False) -> return ()
-    (_, True) -> writeTVar buildStarted False
-
--- | Get the set of all flags available in the given cabal file
-getAvailableFlags :: D.GenericPackageDescription -> Set.Set String
-getAvailableFlags =
-    Set.fromList . map (unFlagName . D.flagName) . D.genPackageFlags
-  where
-#if MIN_VERSION_Cabal(2, 0, 0)
-    unFlagName = D.unFlagName
-#else
-    unFlagName (D.FlagName fn) = fn
-#endif
-
--- | This is the main entry point. Run the devel server.
-devel :: DevelOpts -- ^ command line options
-      -> [String] -- ^ extra options to pass to Stack
-      -> IO ()
-devel opts passThroughArgs = do
-    -- Check that the listening ports are available
     unlessM (checkPort $ develPort opts) $ error "devel port unavailable"
-    unlessM (checkPort $ develTlsPort opts) $ error "devel TLS port unavailable"
+    iappPort <- getPort opts 17834 >>= I.newIORef
+    when (useReverseProxy opts) $ void $ forkIO $ reverseProxy opts iappPort
+    checkDevelFile
+    writeLock opts
 
-    -- Friendly message to the user
+    let (terminator, after) = case terminateWith opts of
-    say "Yesod devel server. Enter 'quit' or hit Ctrl-C to quit."
+          TerminateOnEnter ->
+              ("Press ENTER", void getLine)
+          TerminateOnlyInterrupt ->  -- run for one year
+              ("Interrupt", threadDelay $ 1000 * 1000 * 60 * 60 * 24 * 365)
 
-    -- Find out the name of our package, needed for the upcoming Stack
-    -- commands
-#if MIN_VERSION_Cabal(3, 0, 0)
-    cabal  <- D.tryFindPackageDesc D.silent "."
-#elif MIN_VERSION_Cabal(1, 20, 0)
-    cabal  <- D.tryFindPackageDesc "."
-#else
-    cabal  <- D.findPackageDesc "."
-#endif
 
-#if MIN_VERSION_Cabal(2, 0, 0)
+    putStrLn $ "Yesod devel server. "  ++ terminator ++ " to quit"
-    gpd    <- D.readGenericPackageDescription D.normal cabal
+    void $ forkIO $ do
-#else
+      filesModified <- newEmptyMVar
-    gpd    <- D.readPackageDescription D.normal cabal
+      void $ forkIO $
-#endif
+        void $ watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
-
+      evalStateT (mainOuterLoop iappPort filesModified) Map.empty
-    let pd = D.packageDescription gpd
+    after
-        D.PackageIdentifier packageNameWrapped _version = D.package pd
+    writeLock opts
-#if MIN_VERSION_Cabal(2, 0, 0)
+    exitSuccess
-        packageName = D.unPackageName packageNameWrapped
-#else
-        D.PackageName packageName = packageNameWrapped
-#endif
-
-    -- Which file contains the code to run
-    develHsPath <- checkDevelFile
-
-    -- The port that we're currently listening on, and that the
-    -- reverse proxy should point to
-    appPortVar <- newTVarIO (-1)
-
-    -- If we're actually using reverse proxying, spawn off a reverse
-    -- proxy thread
-    let withRevProxy =
-          if useReverseProxy opts
-            then race_ (reverseProxy opts appPortVar)
-            else id
-
-    -- Run the following concurrently. If any of them exit, take the
-    -- whole thing down.
-    --
-    -- We need to put withChangedVar outside of all this, since we
-    -- need to ensure we start watching files before the stack build
-    -- loop starts.
-    withChangedVar $ \changedVar -> withRevProxy $ race_
-        -- Start the build loop
-        (runStackBuild appPortVar packageName (getAvailableFlags gpd))
-
-        -- Run the app itself, restarting when a build succeeds
-        (runApp appPortVar changedVar develHsPath)
   where
-    -- say, but only when verbose is on
+    bd = getBuildDir opts
-    sayV = when (verbose opts) . sayString
 
-    -- Leverage "stack build --file-watch" to do the build
+    -- outer loop re-reads the cabal file
-    runStackBuild :: TVar Int -> [Char] -> Set.Set [Char] -> IO ()
+    mainOuterLoop iappPort filesModified = do
-    runStackBuild appPortVar packageName availableFlags = do
+      ghcVer <- liftIO ghcVersion
-        -- We call into this app for the devel-signal command
+      cabal  <- liftIO $ D.findPackageDesc "."
-        myPath <- getExecutablePath
+      gpd    <- liftIO $ D.readPackageDescription D.normal cabal
-        let procConfig = setStdout createSource
+      ldar   <- liftIO lookupLdAr
-                       $ setStderr createSource
+      (hsSourceDirs, _) <- liftIO $ checkCabalFile gpd
-                       $ setCreateGroup True -- because need when yesod-bin killed and kill child ghc
+      liftIO $ removeFileIfExists (bd </> "setup-config")
-                       $ proc "stack" $
+      c <- liftIO $ configure opts passThroughArgs
-                [ "build"
+      if c then do
-                , "--fast"
+             -- these files contain the wrong data after the configure step,
-                , "--file-watch"
+             -- remove them to force a cabal build first
+             liftIO $ mapM_ removeFileIfExists [ "yesod-devel/ghcargs.txt"
+                                               , "yesod-devel/arargs.txt"
+                                               , "yesod-devel/ldargs.txt"
+                                               ]
+             rebuild <- liftIO $ mkRebuild ghcVer cabal opts ldar
+             mainInnerLoop iappPort hsSourceDirs filesModified cabal rebuild
+           else do
+             liftIO (threadDelay 5000000)
+             mainOuterLoop iappPort filesModified
 
-                -- Indicate the component we want
+    -- inner loop rebuilds after files change
-                , packageName ++ ":lib"
+    mainInnerLoop iappPort hsSourceDirs filesModified cabal rebuild = go
+       where
+         go = do
+           _ <- recompDeps hsSourceDirs
+           list <- liftIO $ getFileList hsSourceDirs [cabal]
+           success <- liftIO rebuild
+           pkgArgs <- liftIO (ghcPackageArgs opts)
+           let devArgs = pkgArgs ++ ["+RTS", "-I0", "-RTS", "devel.hs"]
+           let loop list0 = do
+                   (haskellFileChanged, list1) <- liftIO $
+                       watchForChanges filesModified hsSourceDirs [cabal] list0 (eventTimeout opts)
+                   anyTouched <- recompDeps hsSourceDirs
+                   unless (anyTouched || haskellFileChanged) $ loop list1
+           if not success
+             then liftIO $ do
+                   putStrLn "\x1b[1;31mBuild failure, pausing...\x1b[0m"
+                   runBuildHook $ failHook opts
+             else do
+                   liftIO $ runBuildHook $ successHook opts
+                   liftIO $ removeLock opts
+                   liftIO $ putStrLn
+                            $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs
+                                              else "Starting development server..."
+                   env0 <- liftIO getEnvironment
 
-                -- signal the watcher that a build has succeeded
+                   -- get a new port for the new process to listen on
-                , "--exec", myPath ++ " devel-signal"
+                   appPort <- liftIO $ I.readIORef iappPort >>= getPort opts . (+ 1)
-                ] ++
+                   liftIO $ I.writeIORef iappPort appPort
 
-                -- Turn on relevant flags
+                   (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs)
-                concatMap
+                        { env = Just $ Map.toList
-                    (\flagName -> [ "--flag", packageName ++ ":" ++ flagName])
+                                     $ Map.insert "PORT" (show appPort)
-                    (Set.toList $ Set.intersection
+                                     $ Map.insert "DISPLAY_PORT" (show $ develPort opts)
-                        availableFlags
+                                     $ Map.fromList env0
-                        (Set.fromList ["dev", "library-only"])) ++
+                        }
+                   derefMap <- get
+                   watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do
+                      loop list
+                      liftIO $ do
+                         putStrLn "Stopping development server..."
+                         writeLock opts
+                         threadDelay 1000000
+                         putStrLn "Terminating development server..."
+                         terminateProcess ph
+                   ec <- liftIO $ waitForProcess' ph
+                   liftIO $ putStrLn $ "Exit code: " ++ show ec
+                   liftIO $ Ex.throwTo watchTid (userError "process finished")
+           loop list
+           n <- liftIO $ cabal `isNewerThan` (bd </> "setup-config")
+           if n then mainOuterLoop iappPort filesModified else go
 
-                -- Add the success hook
+runBuildHook :: Maybe String -> IO ()
-                (case successHook opts of
+runBuildHook (Just s) = do
-                    Nothing -> []
+             ret <- system s
-                    Just h -> ["--exec", h]) ++
+             case ret of
+                  ExitFailure _ -> putStrLn ("Error executing hook: " ++ s)
+                  _             -> return ()
+runBuildHook Nothing = return ()
 
-                -- Any extra args passed on the command line
+{-
-                passThroughArgs
+   run `cabal configure' with our wrappers
+-}
+configure :: DevelOpts -> [String] -> IO Bool
+configure opts extraArgs =
+  checkExit =<< createProcess (proc (cabalProgram opts) $
+                                 [ "configure"
+                                 , "-flibrary-only"
+                                 , "-fdevel"
+                                 , "--disable-library-profiling"
+                                 , "--with-ld=yesod-ld-wrapper"
+                                 , "--with-ghc=yesod-ghc-wrapper"
+                                 , "--with-ar=yesod-ar-wrapper"
+                                 , "--with-hc-pkg=ghc-pkg"
+                                 ] ++ extraArgs
+               )
 
-        sayV $ show procConfig
+removeFileIfExists :: FilePath -> IO ()
-        buildStarted <- newTVarIO False
+removeFileIfExists file = removeFile file `Ex.catch` handler
-        -- Monitor the stdout and stderr content from the build process. Any
+    where
-        -- time some output comes, we invalidate the currently running app by
+      handler :: IOError -> IO ()
-        -- changing the destination port for reverse proxying to -1. We also
+      handler e | isDoesNotExistError e = return ()
-        -- make sure that all content to stdout or stderr from the build
+                | otherwise             = Ex.throw e
-        -- process is piped to the actual stdout and stderr handles.
-        withProcess_ procConfig $ \p -> do
-            let helper getter h =
-                      runConduit
-                    $ getter p
-                   .| iterMC (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
-                   .| sinkHandle h
-            race_ (helper getStdout stdout) (helper getStderr stderr)
 
-    -- Run the inner action with a TVar which will be set to True
+mkRebuild :: String -> FilePath -> DevelOpts -> (FilePath, FilePath) -> IO (IO Bool)
-    -- whenever the signal file is modified.
+mkRebuild ghcVer cabalFile opts (ldPath, arPath)
-    withChangedVar :: (TVar Bool -> IO a) -> IO a
+  | GHC.cProjectVersion /= ghcVer =
-    withChangedVar inner = withManager $ \manager -> do
+       failWith "Yesod has been compiled with a different GHC version, please reinstall"
-        -- Variable indicating that the signal file has been changed. We
+  | forceCabal opts               = return (rebuildCabal opts)
-        -- reset it each time we handle the signal.
+  | otherwise                     =
-        changedVar <- newTVarIO False
+      return $ do
+        ns <- mapM (cabalFile `isNewerThan`)
+           [ "yesod-devel/ghcargs.txt", "yesod-devel/arargs.txt", "yesod-devel/ldargs.txt" ]
+        if or ns
+          then rebuildCabal opts
+          else do
+            bf <- getBuildFlags
+            rebuildGhc bf ldPath arPath
 
-        -- Get the absolute path of the signal file, needed for the
-        -- file watching
-        develSignalFile' <- canonicalizeSpecialFile SignalFile
 
-        -- Start watching the signal file, and set changedVar to
+rebuildGhc :: [Located String] -> FilePath -> FilePath -> IO Bool
-        -- True each time it's changed.
+rebuildGhc bf ld ar = do
-        void $ watchDir manager
+  putStrLn "Rebuilding application... (using GHC API)"
-                -- Using fromString to work with older versions of fsnotify
+  buildPackage bf ld ar
-                -- that use system-filepath
-                (fromString (takeDirectory develSignalFile'))
-                (\e -> eventPath e == fromString develSignalFile')
-                (const $ atomically $ writeTVar changedVar True)
 
-        -- Run the inner action
+rebuildCabal :: DevelOpts -> IO Bool
-        inner changedVar
+rebuildCabal opts = do
+  putStrLn $ "Rebuilding application... (using " ++ cabalProgram opts ++ ")"
+  checkExit =<< createProcess (proc (cabalProgram opts) args)
+    where
+      args | verbose opts = [ "build" ]
+           | otherwise    = [ "build", "-v0" ]
 
-    -- Each time the library builds successfully, run the application
+try_ :: forall a. IO a -> IO ()
-    runApp :: TVar Int -> TVar Bool -> String -> IO b
+try_ x = void (Ex.try x :: IO (Either Ex.SomeException a))
-    runApp appPortVar changedVar develHsPath = do
-        -- Wait for the first change, indicating that the library
-        -- has been built
-        atomically $ do
-            changed <- readTVar changedVar
-            check changed
-            writeTVar changedVar False
 
-        sayV "First successful build complete, running app"
+type FileList = Map.Map FilePath EpochTime
 
-        -- We're going to set the PORT and DISPLAY_PORT variables for
+getFileList :: [FilePath] -> [FilePath] -> IO FileList
-        -- the child below. Also need to know if the env program
+getFileList hsSourceDirs extraFiles = do
-        -- exists.
+    (files, deps) <- getDeps hsSourceDirs
-        env <- fmap Map.fromList getEnvironment
+    let files' = extraFiles ++ files ++ map fst (Map.toList deps)
-        hasEnv <- fmap isJust $ findExecutable "env"
+    fmap Map.fromList $ forM files' $ \f -> do
+        efs <- Ex.try $ getFileStatus f
+        return $ case efs of
+            Left (_ :: Ex.SomeException) -> (f, 0)
+            Right fs -> (f, modificationTime fs)
 
-        -- Keep looping forever, print any synchronous exceptions,
+-- | Returns @True@ if a .hs file changed.
-        -- and eventually die from an async exception from one of
+watchForChanges :: MVar () -> [FilePath] -> [FilePath] -> FileList -> Int -> IO (Bool, FileList)
-        -- the other threads (via race_ above).
+watchForChanges filesModified hsSourceDirs extraFiles list t = do
-        forever $ Ex.handleAny (\e -> sayErrString $ "Exception in runApp: " ++ show e) $ do
+    newList <- getFileList hsSourceDirs extraFiles
-            -- Get the port the child should listen on, and tell
+    if list /= newList
-            -- the reverse proxy about it
+      then do
-            newPort <-
+        let haskellFileChanged = not $ Map.null $ Map.filterWithKey isHaskell $
-                if useReverseProxy opts
+                Map.differenceWith compareTimes newList list `Map.union`
-                    then getNewPort opts
+                Map.differenceWith compareTimes list newList
-                    -- no reverse proxy, so use the develPort directly
+        return (haskellFileChanged, newList)
-                    else return (develPort opts)
+      else timeout (1000000*t) (takeMVar filesModified) >>
-            atomically $ writeTVar appPortVar newPort
+           watchForChanges filesModified hsSourceDirs extraFiles list t
+  where
+    compareTimes x y
+        | x == y = Nothing
+        | otherwise = Just x
 
-            -- Modified environment
+    isHaskell filename _ = takeExtension filename `elem` [".hs", ".lhs", ".hsc", ".cabal"]
-            let env' = Map.toList
-                        $ Map.insert "PORT" (show newPort)
-                        $ Map.insert "DISPLAY_PORT" (show $ develPort opts)
-                        env
 
-            -- Remove the terminate file so we don't immediately exit
+checkDevelFile :: IO ()
-            removeSpecialFile TermFile
+checkDevelFile = do
+  e <- doesFileExist "devel.hs"
+  unless e $ failWith "file devel.hs not found"
 
-            -- Launch the main function in the Main module defined
+checkCabalFile :: D.GenericPackageDescription -> IO ([FilePath], D.Library)
-            -- in the file develHsPath. We use ghc instead of
+checkCabalFile gpd = case D.condLibrary gpd of
-            -- runghc to avoid the extra (confusing) resident
+    Nothing -> failWith "incorrect cabal file, no library"
-            -- runghc process. Starting with GHC 8.0.2, that will
+    Just ct ->
-            -- not be necessary.
+      case lookupDevelLib gpd ct of
+        Nothing   ->
+          failWith "no development flag found in your configuration file. Expected a 'library-only' flag or the older 'devel' flag"
+        Just dLib -> do
+           let hsSourceDirs = D.hsSourceDirs . D.libBuildInfo $ dLib
+           fl <- getFileList hsSourceDirs []
+           let unlisted = checkFileList fl dLib
+           unless (null unlisted) $ do
+                putStrLn "WARNING: the following source files are not listed in exposed-modules or other-modules:"
+                mapM_ putStrLn unlisted
+           when (D.fromString "Application" `notElem` D.exposedModules dLib) $
+                putStrLn "WARNING: no exposed module Application"
+           return (hsSourceDirs, dLib)
 
-            {- Hmm, unknown errors trying to get this to work. Just doing the
+failWith :: String -> IO a
-             - runghc thing instead.
+failWith msg = do
+    putStrLn $ "ERROR: " ++ msg
+    exitFailure
 
-            let procDef = setStdin closed $ setEnv env' $ proc "stack"
+checkFileList :: FileList -> D.Library -> [FilePath]
-                    [ "ghc"
+checkFileList fl lib = filter (not . isSetup) . filter isUnlisted . filter isSrcFile $ sourceFiles
-                    , "--"
+  where
-                    , develHsPath
+    al = allModules lib
-                    , "-e"
+    -- a file is only a possible 'module file' if all path pieces start with a capital letter
-                    , "Main.main"
+    sourceFiles = filter isSrcFile . map fst . Map.toList $ fl
-                    ]
+    isSrcFile file = let dirs = filter (/=".") $ splitDirectories file
-            -}
+                     in  all (isUpper . head) dirs && (takeExtension file `elem` [".hs", ".lhs"])
+    isUnlisted file = not (toModuleName file `Set.member` al)
+    toModuleName = L.intercalate "." . filter (/=".") . splitDirectories . dropExtension
 
-            -- Nix support in Stack doesn't pass along env vars by
+    isSetup "Setup.hs" = True
-            -- default, so we use the env command. But if the command
+    isSetup "./Setup.hs" = True
-            -- isn't available, just set the env var. I'm sure this
+    isSetup "Setup.lhs" = True
-            -- will break _some_ combination of systems, but we'll
+    isSetup "./Setup.lhs" = True
-            -- deal with that later. Previous issues:
+    isSetup _ = False
-            --
-            -- https://github.com/yesodweb/yesod/issues/1357
-            -- https://github.com/yesodweb/yesod/issues/1359
-            let procDef
-                  | hasEnv = setStdin closed $ proc "stack"
-                    [ "exec"
-                    , "--"
-                    , "env"
-                    , "PORT=" ++ show newPort
-                    , "DISPLAY_PORT=" ++ show (develPort opts)
-                    , "runghc"
-                    , develHsPath
-                    ]
-                  | otherwise = setStdin closed $ setEnv env' $ proc "stack"
-                    [ "runghc"
-                    , "--"
-                    , develHsPath
-                    ]
 
-            sayV $ "Running child process: " ++ show procDef
+allModules :: D.Library -> Set.Set String
+allModules lib = Set.fromList $ map toString $ D.exposedModules lib ++ (D.otherModules . D.libBuildInfo) lib
+    where
+      toString = L.intercalate "." . D.components
 
-            -- Start running the child process with GHC
+ghcVersion :: IO String
-            withProcess procDef $ \p -> do
+ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] []
-                -- Wait for either the process to exit, or for a new build to come through
+    where
-                eres <- atomically (fmap Left (waitExitCodeSTM p) <|> fmap Right
+      getNumber = filter (\x -> isNumber x || x == '.')
-                    (do changed <- readTVar changedVar
-                        check changed
-                        writeTVar changedVar False))
-                            -- on an async exception, make sure the child dies
-                            `Ex.onException` writeSpecialFile TermFile
-                case eres of
-                    -- Child exited, which indicates some
-                    -- error. Let the user know, sleep for a bit
-                    -- to avoid busy-looping, and then we'll try
-                    -- again.
-                    Left ec -> do
-                        sayErrString $ "Unexpected: child process exited with " ++ show ec
-                        threadDelay 1000000
-                        sayErrString "Trying again"
-                    -- New build succeeded
-                    Right () -> do
-                        -- Kill the child process, both with the
-                        -- TermFile, and by signaling the process
-                        -- directly.
-                        writeSpecialFile TermFile
-                        stopProcess p
 
-                        -- Wait until the child properly exits, then we'll try again
+ghcPackageArgs :: DevelOpts -> IO [String]
-                        ec <- waitExitCode p
+ghcPackageArgs opts = getBuildFlags >>= getPackageArgs (buildDir opts)
-                        sayV $ "Expected: child process exited with " ++ show ec
+
+lookupDevelLib :: D.GenericPackageDescription -> D.CondTree D.ConfVar c a -> Maybe a
+lookupDevelLib gpd ct | found     = Just (D.condTreeData ct)
+                      | otherwise = Nothing
+  where
+    flags = map (unFlagName . D.flagName) $ D.genPackageFlags gpd
+    unFlagName (D.FlagName x) = x
+    found = any (`elem` ["library-only", "devel"]) flags
+
+-- location of `ld' and `ar' programs
+lookupLdAr :: IO (FilePath, FilePath)
+lookupLdAr = do
+  mla <- lookupLdAr'
+  case mla of
+    Nothing -> failWith "Cannot determine location of `ar' or `ld' program"
+    Just la -> return la
+
+lookupLdAr' :: IO (Maybe (FilePath, FilePath))
+lookupLdAr' = do
+  (_, pgmc) <- D.configCompiler (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent
+  pgmc' <- D.configureAllKnownPrograms D.silent pgmc
+  return $ (,) <$> look D.ldProgram pgmc' <*> look D.arProgram pgmc'
+     where
+       look pgm pdb = fmap D.programPath (D.lookupProgram pgm pdb)
+
+-- | nonblocking version of @waitForProcess@
+waitForProcess' :: ProcessHandle -> IO ExitCode
+waitForProcess' pid = go
+  where
+    go = do
+      mec <- getProcessExitCode pid
+      case mec of
+        Just ec -> return ec
+        Nothing -> threadDelay 100000 >> go
+
+-- | wait for process started by @createProcess@, return True for ExitSuccess
+checkExit :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO Bool
+checkExit (_,_,_,h) = (==ExitSuccess) <$> waitForProcess' h

yesod-bin/GhcBuild.hs

@@ -0,0 +1,498 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# OPTIONS_GHC -fno-warn-unused-matches #-}
+{-
+  There is a lot of code copied from GHC here, and some conditional
+  compilation. Instead of fixing all warnings and making it much more
+  difficult to compare the code to the original, just ignore unused
+  binds and imports.
+-}
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE PatternGuards       #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-
+  build package with the GHC API
+-}
+
+module GhcBuild (getBuildFlags, buildPackage, getPackageArgs) where
+
+import qualified Control.Exception as Ex
+import           Control.Monad      (when)
+import           Data.IORef
+import           System.Process     (rawSystem)
+import           System.Environment (getEnvironment)
+
+import           CmdLineParser
+import           Data.Char          (toLower)
+import           Data.List          (isPrefixOf, isSuffixOf, partition)
+import           Data.Maybe         (fromMaybe)
+import           DriverPhases       (Phase (..), anyHsc, isHaskellSrcFilename,
+                                     isSourceFilename, startPhase)
+import           DriverPipeline     (compileFile, link, linkBinary, oneShot)
+import           DynFlags           (DynFlags, compilerInfo)
+import qualified DynFlags
+import qualified DynFlags           as DF
+import qualified GHC
+import           GHC.Paths          (libdir)
+import           HscTypes           (HscEnv (..), emptyHomePackageTable)
+import qualified Module
+import           MonadUtils         (liftIO)
+import           Panic              (throwGhcException, panic)
+import           SrcLoc             (Located, mkGeneralLocated)
+import qualified StaticFlags
+#if __GLASGOW_HASKELL__ >= 707
+import           DynFlags           (ldInputs)
+#else
+import           StaticFlags        (v_Ld_inputs)
+#endif
+import           System.FilePath    (normalise, (</>))
+import           Util               (consIORef, looksLikeModuleName)
+
+{-
+  This contains a huge hack:
+  GHC only accepts setting static flags once per process, however it has no way to
+  get the remaining options from the command line, without setting the static flags.
+  This code overwrites the IORef to disable the check. This will likely cause
+  problems if the flags are modified, but fortunately that's relatively uncommon.
+-}
+getBuildFlags :: IO [Located String]
+getBuildFlags = do
+  argv0 <- fmap read $ readFile "yesod-devel/ghcargs.txt" -- generated by yesod-ghc-wrapper
+  argv0' <- prependHsenvArgv argv0
+  let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0'
+      mbMinusB | null minusB_args = Nothing
+               | otherwise = Just (drop 2 (last minusB_args))
+  let argv1' = map (mkGeneralLocated "on the commandline") argv1
+  writeIORef StaticFlags.v_opt_C_ready False -- the huge hack
+  (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1'
+  return argv2
+
+prependHsenvArgv :: [String] -> IO [String]
+prependHsenvArgv argv = do
+  env <- getEnvironment
+  return $ case (lookup "HSENV" env) of
+             Nothing -> argv
+             _       -> hsenvArgv ++ argv
+                 where hsenvArgv = words $ fromMaybe "" (lookup "PACKAGE_DB_FOR_GHC" env)
+
+-- construct a command line for loading the right packages
+getPackageArgs :: Maybe String -> [Located String] -> IO [String]
+getPackageArgs buildDir argv2 = do
+  (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
+  GHC.runGhc (Just libdir) $ do
+    dflags0 <- GHC.getSessionDynFlags
+    (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3
+    let pkgFlags = map convertPkgFlag (GHC.packageFlags dflags1)
+        hideAll | gopt DF.Opt_HideAllPackages dflags1 = [ "-hide-all-packages"]
+                | otherwise                           = []
+        ownPkg = "-package-id" ++ Module.packageIdString (DF.thisPackage dflags1) ++ "-inplace"
+    return (extra dflags1 ++ hideAll ++ pkgFlags ++ [ownPkg])
+  where
+    convertPkgFlag (DF.ExposePackage p)   = "-package" ++ p
+    convertPkgFlag (DF.ExposePackageId p) = "-package-id" ++ p
+    convertPkgFlag (DF.HidePackage p)     = "-hide-package" ++ p
+    convertPkgFlag (DF.IgnorePackage p)   = "-ignore-package" ++ p
+    convertPkgFlag (DF.TrustPackage p)    = "-trust" ++ p
+    convertPkgFlag (DF.DistrustPackage p) ="-distrust" ++ p
+#if __GLASGOW_HASKELL__ >= 705
+    extra df = inplaceConf ++ extra'
+      where
+         extra' = concatMap convertExtra (extraConfs df)
+         -- old cabal-install sometimes misses the .inplace db, fix it here
+         inplaceConf
+           | any (".inplace" `isSuffixOf`) extra' = []
+           | otherwise = ["-package-db" ++ fromMaybe "dist" buildDir
+                           ++ "/package.conf.inplace"]
+    extraConfs df = GHC.extraPkgConfs df []
+    convertExtra DF.GlobalPkgConf      = [ ]
+    convertExtra DF.UserPkgConf        = [ ]
+    convertExtra (DF.PkgConfFile file) = [ "-package-db" ++ file ]
+#else
+    extra df  = inplaceConf ++ extra'
+      where
+        extra' = map ("-package-conf"++) (GHC.extraPkgConfs df)
+         -- old cabal-install sometimes misses the .inplace db, fix it here
+        inplaceConf
+          | any (".inplace" `isSuffixOf`) extra' = []
+          | otherwise = ["-package-conf" ++ fromMaybe "dist" buildDir
+                           ++ "/package.conf.inplace"]
+#endif
+
+#if __GLASGOW_HASKELL__ >= 707
+    gopt = DF.gopt
+#else
+    gopt = DF.dopt
+#endif
+
+
+buildPackage :: [Located String] -> FilePath -> FilePath -> IO Bool
+buildPackage a ld ar = buildPackage' a ld ar `Ex.catch` \e -> do
+  putStrLn ("exception building package: " ++ show (e :: Ex.SomeException))
+  return False
+
+buildPackage' :: [Located String] -> FilePath -> FilePath -> IO Bool
+buildPackage' argv2 ld ar = do
+  (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
+  GHC.runGhc (Just libdir) $ do
+    dflags0 <- GHC.getSessionDynFlags
+    (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3
+    let dflags2 = dflags1 { GHC.ghcMode   = GHC.CompManager
+                          , GHC.hscTarget = GHC.hscTarget dflags1
+                          , GHC.ghcLink   = GHC.LinkBinary
+                          , GHC.verbosity = 1
+                          }
+    (dflags3, fileish_args, _) <- GHC.parseDynamicFlags dflags2 argv3
+    GHC.setSessionDynFlags dflags3
+    let normal_fileish_paths = map (normalise . GHC.unLoc) fileish_args
+        (srcs, objs)         = partition_args normal_fileish_paths [] []
+        (hs_srcs, non_hs_srcs) = partition haskellish srcs
+        haskellish (f,Nothing) =
+          looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
+        haskellish (_,Just phase) =
+#if MIN_VERSION_ghc(7,8,3)
+          phase `notElem` [As True, As False, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
+#elif MIN_VERSION_ghc(7,4,0)
+          phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
+#else
+          phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
+#endif
+    hsc_env <- GHC.getSession
+--    if (null hs_srcs)
+--       then liftIO (oneShot hsc_env StopLn srcs)
+--       else do
+#if MIN_VERSION_ghc(7,2,0)
+    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
+#else
+    o_files <- mapM (\x -> compileFile hsc_env StopLn x)
+#endif
+                 non_hs_srcs
+#if __GLASGOW_HASKELL__ >= 707
+    let dflags4 = dflags3
+            { ldInputs = map (DF.FileOption "") (reverse o_files)
+                      ++ ldInputs dflags3
+            }
+    GHC.setSessionDynFlags dflags4
+#else
+    liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
+#endif
+    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
+    GHC.setTargets targets
+    ok_flag <- GHC.load GHC.LoadAllTargets
+    if GHC.failed ok_flag
+      then return False
+      else liftIO (linkPkg ld ar) >> return True
+
+linkPkg :: FilePath -> FilePath -> IO ()
+linkPkg ld ar = do
+  arargs <- fmap read $ readFile "yesod-devel/arargs.txt"
+  rawSystem ar arargs
+  ldargs <- fmap read $ readFile "yesod-devel/ldargs.txt"
+  rawSystem ld ldargs
+  return ()
+
+--------------------------------------------------------------------------------------------
+-- stuff below copied from ghc main.hs
+--------------------------------------------------------------------------------------------
+
+partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
+               -> ([(String, Maybe Phase)], [String])
+partition_args [] srcs objs = (reverse srcs, reverse objs)
+partition_args ("-x":suff:args) srcs objs
+  | "none" <- suff      = partition_args args srcs objs
+  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
+  | otherwise           = partition_args rest (these_srcs ++ srcs) objs
+        where phase = startPhase suff
+              (slurp,rest) = break (== "-x") args
+              these_srcs = zip slurp (repeat (Just phase))
+partition_args (arg:args) srcs objs
+  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
+  | otherwise               = partition_args args srcs (arg:objs)
+
+    {-
+      We split out the object files (.o, .dll) and add them
+      to v_Ld_inputs for use by the linker.
+
+      The following things should be considered compilation manager inputs:
+
+       - haskell source files (strings ending in .hs, .lhs or other
+         haskellish extension),
+
+       - module names (not forgetting hierarchical module names),
+
+       - and finally we consider everything not containing a '.' to be
+         a comp manager input, as shorthand for a .hs or .lhs filename.
+
+      Everything else is considered to be a linker object, and passed
+      straight through to the linker.
+    -}
+looks_like_an_input :: String -> Bool
+looks_like_an_input m =  isSourceFilename m
+                      || looksLikeModuleName m
+                      || '.' `notElem` m
+
+
+
+-- Parsing the mode flag
+
+parseModeFlags :: [Located String]
+               -> IO (Mode,
+                      [Located String],
+                      [Located String])
+parseModeFlags args = do
+  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
+          runCmdLine (processArgs mode_flags args)
+                     (Nothing, [], [])
+      mode = case mModeFlag of
+             Nothing     -> doMakeMode
+             Just (m, _) -> m
+      errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
+  when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
+  return (mode, flags' ++ leftover, warns)
+
+type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
+  -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
+  -- so we collect the new ones and return them.
+
+mode_flags :: [Flag ModeM]
+mode_flags =
+  [  ------- help / version ----------------------------------------------
+    Flag "?"                     (PassFlag (setMode showGhcUsageMode))
+  , Flag "-help"                 (PassFlag (setMode showGhcUsageMode))
+  , Flag "V"                     (PassFlag (setMode showVersionMode))
+  , Flag "-version"              (PassFlag (setMode showVersionMode))
+  , Flag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
+  , Flag "-info"                 (PassFlag (setMode showInfoMode))
+  , Flag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
+  , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
+  ] ++
+  [ Flag k'                      (PassFlag (setMode (printSetting k)))
+  | k <- ["Project version",
+          "Booter version",
+          "Stage",
+          "Build platform",
+          "Host platform",
+          "Target platform",
+          "Have interpreter",
+          "Object splitting supported",
+          "Have native code generator",
+          "Support SMP",
+          "Unregisterised",
+          "Tables next to code",
+          "RTS ways",
+          "Leading underscore",
+          "Debug on",
+          "LibDir",
+          "Global Package DB",
+          "C compiler flags",
+          "Gcc Linker flags",
+          "Ld Linker flags"],
+    let k' = "-print-" ++ map (replaceSpace . toLower) k
+        replaceSpace ' ' = '-'
+        replaceSpace c   = c
+  ] ++
+      ------- interfaces ----------------------------------------------------
+  [ Flag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
+                                               "--show-iface"))
+
+      ------- primary modes ------------------------------------------------
+  , Flag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
+                                            addFlag "-no-link" f))
+  , Flag "M"            (PassFlag (setMode doMkDependHSMode))
+  , Flag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
+  , Flag "C"            (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
+                                            addFlag "-fvia-C" f))
+#if MIN_VERSION_ghc(7,8,3)
+  , Flag "S"            (PassFlag (setMode (stopBeforeMode (As True))))
+#else
+  , Flag "S"            (PassFlag (setMode (stopBeforeMode As)))
+#endif
+  , Flag "-make"        (PassFlag (setMode doMakeMode))
+  , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
+  , Flag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
+  , Flag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
+  ]
+
+setMode :: Mode -> String -> EwM ModeM ()
+setMode newMode newFlag = liftEwM $ do
+    (mModeFlag, errs, flags') <- getCmdLineState
+    let (modeFlag', errs') =
+            case mModeFlag of
+            Nothing -> ((newMode, newFlag), errs)
+            Just (oldMode, oldFlag) ->
+                case (oldMode, newMode) of
+                    -- -c/--make are allowed together, and mean --make -no-link
+                    _ |  isStopLnMode oldMode && isDoMakeMode newMode
+                      || isStopLnMode newMode && isDoMakeMode oldMode ->
+                      ((doMakeMode, "--make"), [])
+
+                    -- If we have both --help and --interactive then we
+                    -- want showGhciUsage
+                    _ | isShowGhcUsageMode oldMode &&
+                        isDoInteractiveMode newMode ->
+                            ((showGhciUsageMode, oldFlag), [])
+                      | isShowGhcUsageMode newMode &&
+                        isDoInteractiveMode oldMode ->
+                            ((showGhciUsageMode, newFlag), [])
+                    -- Otherwise, --help/--version/--numeric-version always win
+                      | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
+                      | isDominantFlag newMode -> ((newMode, newFlag), [])
+                    -- We need to accumulate eval flags like "-e foo -e bar"
+                    (Right (Right (DoEval esOld)),
+                     Right (Right (DoEval [eNew]))) ->
+                        ((Right (Right (DoEval (eNew : esOld))), oldFlag),
+                         errs)
+                    -- Saying e.g. --interactive --interactive is OK
+                    _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
+                    -- Otherwise, complain
+                    _ -> let err = flagMismatchErr oldFlag newFlag
+                         in ((oldMode, oldFlag), err : errs)
+    putCmdLineState (Just modeFlag', errs', flags')
+  where isDominantFlag f = isShowGhcUsageMode   f ||
+                           isShowGhciUsageMode  f ||
+                           isShowVersionMode    f ||
+                           isShowNumVersionMode f
+
+flagMismatchErr :: String -> String -> String
+flagMismatchErr oldFlag newFlag
+    = "cannot use `" ++ oldFlag ++  "' with `" ++ newFlag ++ "'"
+
+addFlag :: String -> String -> EwM ModeM ()
+addFlag s flag = liftEwM $ do
+  (m, e, flags') <- getCmdLineState
+  putCmdLineState (m, e, mkGeneralLocated loc s : flags')
+    where loc = "addFlag by " ++ flag ++ " on the commandline"
+
+type Mode = Either PreStartupMode PostStartupMode
+type PostStartupMode = Either PreLoadMode PostLoadMode
+
+data PreStartupMode
+  = ShowVersion             -- ghc -V/--version
+  | ShowNumVersion          -- ghc --numeric-version
+  | ShowSupportedExtensions -- ghc --supported-extensions
+  | Print String            -- ghc --print-foo
+
+showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
+showVersionMode             = mkPreStartupMode ShowVersion
+showNumVersionMode          = mkPreStartupMode ShowNumVersion
+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
+
+mkPreStartupMode :: PreStartupMode -> Mode
+mkPreStartupMode = Left
+
+isShowVersionMode :: Mode -> Bool
+isShowVersionMode (Left ShowVersion) = True
+isShowVersionMode _ = False
+
+isShowNumVersionMode :: Mode -> Bool
+isShowNumVersionMode (Left ShowNumVersion) = True
+isShowNumVersionMode _ = False
+
+data PreLoadMode
+  = ShowGhcUsage                           -- ghc -?
+  | ShowGhciUsage                          -- ghci -?
+  | ShowInfo                               -- ghc --info
+  | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
+
+showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
+showGhcUsageMode = mkPreLoadMode ShowGhcUsage
+showGhciUsageMode = mkPreLoadMode ShowGhciUsage
+showInfoMode = mkPreLoadMode ShowInfo
+
+printSetting :: String -> Mode
+printSetting k = mkPreLoadMode (PrintWithDynFlags f)
+    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
+#if MIN_VERSION_ghc(7,2,0)
+                   $ lookup k (compilerInfo dflags)
+#else
+                   $ fmap convertPrintable (lookup k compilerInfo)
+              where
+                convertPrintable (DynFlags.String s) = s
+                convertPrintable (DynFlags.FromDynFlags f) = f dflags
+#endif
+
+mkPreLoadMode :: PreLoadMode -> Mode
+mkPreLoadMode = Right . Left
+
+isShowGhcUsageMode :: Mode -> Bool
+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
+isShowGhcUsageMode _ = False
+
+isShowGhciUsageMode :: Mode -> Bool
+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
+isShowGhciUsageMode _ = False
+
+data PostLoadMode
+  = ShowInterface FilePath  -- ghc --show-iface
+  | DoMkDependHS            -- ghc -M
+  | StopBefore Phase        -- ghc -E | -C | -S
+                            -- StopBefore StopLn is the default
+  | DoMake                  -- ghc --make
+  | DoInteractive           -- ghc --interactive
+  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
+  | DoAbiHash               -- ghc --abi-hash
+
+doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
+doMkDependHSMode = mkPostLoadMode DoMkDependHS
+doMakeMode = mkPostLoadMode DoMake
+doInteractiveMode = mkPostLoadMode DoInteractive
+doAbiHashMode = mkPostLoadMode DoAbiHash
+
+
+showInterfaceMode :: FilePath -> Mode
+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
+
+stopBeforeMode :: Phase -> Mode
+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
+
+doEvalMode :: String -> Mode
+doEvalMode str = mkPostLoadMode (DoEval [str])
+
+mkPostLoadMode :: PostLoadMode -> Mode
+mkPostLoadMode = Right . Right
+
+isDoInteractiveMode :: Mode -> Bool
+isDoInteractiveMode (Right (Right DoInteractive)) = True
+isDoInteractiveMode _ = False
+
+isStopLnMode :: Mode -> Bool
+isStopLnMode (Right (Right (StopBefore StopLn))) = True
+isStopLnMode _ = False
+
+isDoMakeMode :: Mode -> Bool
+isDoMakeMode (Right (Right DoMake)) = True
+isDoMakeMode _ = False
+
+#ifdef GHCI
+isInteractiveMode :: PostLoadMode -> Bool
+isInteractiveMode DoInteractive = True
+isInteractiveMode _             = False
+#endif
+
+-- isInterpretiveMode: byte-code compiler involved
+isInterpretiveMode :: PostLoadMode -> Bool
+isInterpretiveMode DoInteractive = True
+isInterpretiveMode (DoEval _)    = True
+isInterpretiveMode _             = False
+
+needsInputsMode :: PostLoadMode -> Bool
+needsInputsMode DoMkDependHS    = True
+needsInputsMode (StopBefore _)  = True
+needsInputsMode DoMake          = True
+needsInputsMode _               = False
+
+-- True if we are going to attempt to link in this mode.
+-- (we might not actually link, depending on the GhcLink flag)
+isLinkMode :: PostLoadMode -> Bool
+isLinkMode (StopBefore StopLn) = True
+isLinkMode DoMake              = True
+isLinkMode DoInteractive       = True
+isLinkMode (DoEval _)          = True
+isLinkMode _                   = False
+
+isCompManagerMode :: PostLoadMode -> Bool
+isCompManagerMode DoMake        = True
+isCompManagerMode DoInteractive = True
+isCompManagerMode (DoEval _)    = True
+isCompManagerMode _             = False

yesod-bin/HsFile.hs

@@ -1,18 +1,38 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 module HsFile (mkHsFile) where
 import Text.ProjectTemplate (createTemplate)
-import Conduit
+import Data.Conduit 
+    ( ($$), (=$), ConduitM, awaitForever, yield, Source )
+import Control.Monad.Trans.Resource (ResourceT, runResourceT)
+import qualified Data.Conduit.List as CL
+import Prelude hiding (FilePath)
+import Filesystem.Path ( FilePath )
+import Filesystem.Path.CurrentOS ( encodeString )
+import qualified Filesystem as F
 import qualified Data.ByteString as BS
 import Control.Monad.IO.Class (liftIO)
-import Data.String (fromString)
+
+traverse :: FilePath -> Source (ResourceT IO) FilePath
+traverse dir = do
+    liftIO (F.listDirectory dir) >>= mapM_ go
+  where
+    go fp = do
+        isFile' <- liftIO $ F.isFile fp
+        if isFile'
+            then yield fp
+            else do
+                isDir <- liftIO $ F.isDirectory fp
+                if isDir
+                    then traverse fp
+                    else return ()
 
 mkHsFile :: IO ()
-mkHsFile = runConduitRes
+mkHsFile = runResourceT $ traverse "."
-         $ 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)
-    -- Reads a filepath from upstream and dumps a pair of (filepath, filecontents)
+readIt :: ConduitM FilePath (FilePath, ResourceT IO BS.ByteString) (ResourceT IO) ()
-    readIt = mapC $ \i -> (fromString i, liftIO $ BS.readFile i)
+readIt = CL.map $ \i -> (i, liftIO $ BS.readFile $ encodeString i)
+

yesod-bin/Keter.hs

@@ -1,31 +1,22 @@
 {-# 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
-import System.Process
+import System.Cmd
 import Control.Monad
-import System.Directory hiding (findFiles)
+import System.Directory
-import Data.Maybe (mapMaybe,isJust,maybeToList)
+import Data.Maybe (mapMaybe)
-import Data.Monoid
+import qualified Filesystem.Path.CurrentOS as F
-import System.FilePath ((</>))
+import qualified Filesystem as F
 import qualified Codec.Archive.Tar as Tar
 import Control.Exception
 import qualified Data.ByteString.Lazy as L
 import Codec.Compression.GZip (compress)
-import qualified Data.Foldable as Fold
-import Control.Monad.Trans.Writer (tell, execWriter)
 
 run :: String -> [String] -> IO ()
 run a b = do
@@ -34,29 +25,19 @@ run a b = do
 
 keter :: String -- ^ cabal command
       -> Bool -- ^ no build?
-      -> Bool -- ^ no copy to?
-      -> [String] -- ^ build args
       -> IO ()
-keter cabal noBuild noCopyTo buildArgs = do
+keter cabal noBuild = do
-    ketercfg <- keterConfig
+    mvalue <- decodeFile "config/keter.yaml"
-    mvalue <- decodeFile ketercfg
     value <-
         case mvalue of
             Nothing -> error "No config/keter.yaml found"
             Just (Object value) ->
                 case Map.lookup "host" value of
                     Just (String s) | "<<" `T.isPrefixOf` s ->
-                        error $ "Please set your hostname in " ++ ketercfg
+                        error "Please set your hostname in config/keter.yaml"
-                    _ ->
+                    _ -> return value
-                        case Map.lookup "user-edited" value of
+            Just _ -> error "config/keter.yaml is not an object"
-                            Just (Bool False) ->
-                                error $ "Please edit your Keter config file at "
-                                     ++ ketercfg
-                            _ -> return value
-            Just _ -> error $ ketercfg ++ " is not an object"
 
-    env' <- getEnvironment
-    cwd' <- getCurrentDirectory
     files <- getDirectoryContents "."
     project <-
         case mapMaybe (T.stripSuffix ".cabal" . T.pack) files of
@@ -64,77 +45,28 @@ keter cabal noBuild noCopyTo buildArgs = do
             [] -> error "No cabal file found"
             _ -> error "Too many cabal files found"
 
-    let findFiles (Object v) =
+    exec <-
-            mapM_ go $ Map.toList v
+        case Map.lookup "exec" value of
-          where
+            Just (String s) -> return $ F.collapse $ "config" F.</> F.fromText s
-            go ("exec", String s) = tellFile s
+            _ -> error "exec not found in config/keter.yaml"
-            go ("extraFiles", Array a) = Fold.mapM_ tellExtra a
-            go (_, v') = findFiles v'
-            tellFile s = tell [collapse $ "config" </> T.unpack s]
-            tellExtra (String s) = tellFile s
-            tellExtra _          = error "extraFiles should be a flat array"
-        findFiles (Array v) = Fold.mapM_ findFiles v
-        findFiles _ = return ()
-        bundleFiles = execWriter $ findFiles $ Object value
-
-        collapse = T.unpack . T.intercalate "/" . collapse' . T.splitOn "/" . T.pack
-        collapse' (_:"..":rest) = collapse' rest
-        collapse' (".":xs) = collapse' xs
-        collapse' (x:xs) = x : collapse' xs
-        collapse' [] = []
 
     unless noBuild $ do
-        stackQueryRunSuccess <- do
+        run cabal ["clean"]
-            eres <- try $ readProcessWithExitCode "stack" ["query"] "" :: IO (Either IOException (ExitCode, String, String))
+        run cabal ["configure"]
-            return $ either (\_ -> False) (\(ec, _, _) -> (ec == ExitSuccess)) eres
+        run cabal ["build"]
 
-        let inStackExec = isJust $ lookup "STACK_EXE" env'
+    _ <- try' $ F.removeTree "static/tmp"
-            mStackYaml = lookup "STACK_YAML" env'
-            useStack = inStackExec || isJust mStackYaml || stackQueryRunSuccess
 
-        if useStack
+    archive <- Tar.pack "" [F.encodeString exec, "config", "static"]
-            then do let stackYaml = maybeToList $ fmap ("--stack-yaml="<>) mStackYaml
-                        localBinPath = cwd' </> "dist/bin"
-                    run "stack" $ stackYaml <> ["clean"]
-                    createDirectoryIfMissing True localBinPath
-                    run "stack"
-                        (stackYaml
-                         <> ["--local-bin-path",localBinPath,"build","--copy-bins"]
-                         <> buildArgs)
-            else do run cabal ["clean"]
-                    run cabal ["configure"]
-                    run cabal ("build" : buildArgs)
-
-    _ <- try' $ removeDirectoryRecursive "static/tmp"
-
-    archive <- Tar.pack "" $
-        "config" : "static" : bundleFiles
     let fp = T.unpack project ++ ".keter"
     L.writeFile fp $ compress $ Tar.write archive
 
-    unless noCopyTo $ case Map.lookup "copy-to" value of
+    case Map.lookup "copy-to" value of
         Just (String s) ->
-            let baseArgs = [fp, T.unpack s] :: [String]
+            case parseMaybe (.: "copy-to-port") value of
-
+                Just i -> run "scp" ["-P" ++ show (i :: Int), fp, T.unpack s]
-                scpArgs =
+                Nothing -> run "scp" [fp, T.unpack s]
-                    case parseMaybe (.: "copy-to-args") value of
-                        Just as -> as ++ baseArgs
-                        Nothing -> baseArgs
-
-                args =
-                    case parseMaybe (.: "copy-to-port") value of
-                        Just i -> "-P" : show (i :: Int) : scpArgs
-                        Nothing -> scpArgs
-
-            in run "scp" args
-
         _ -> return ()
-  where
-    -- Test for alternative config file extension (yaml or yml).
-    keterConfig = do
-        let yml = "config/keter.yml"
-        ymlExists <- doesFileExist yml
-        return $ if ymlExists then yml else "config/keter.yaml"
 
 try' :: IO a -> IO (Either SomeException a)
 try' = try

yesod-bin/Options.hs

@@ -7,8 +7,6 @@ module Options (injectDefaults) where
 import           Control.Applicative
 import qualified Control.Exception         as E
 import           Control.Monad
-import           Control.Monad.Trans.Except
-import           Control.Monad.Trans.Reader
 import           Data.Char                 (isAlphaNum, isSpace, toLower)
 import           Data.List                 (foldl')
 import           Data.List.Split           (splitOn)
@@ -66,37 +64,34 @@ configLines = mapMaybe (mkLine . takeWhile (/='#')) . lines
 injectDefaultP :: M.Map [String] String -> [String] -> Parser a -> Parser a
 injectDefaultP _env _path n@(NilP{})   = n
 injectDefaultP env path p@(OptP o)
-#if MIN_VERSION_optparse_applicative(0,13,0)
-  | (Option (CmdReader _ cmds f) props) <- o  =
-#else
   | (Option (CmdReader cmds f) props) <- o  =
-#endif
      let cmdMap = M.fromList (map (\c -> (c, mkCmd c)) cmds)
          mkCmd cmd =
            let (Just parseri) = f cmd
            in  parseri { infoParser = injectDefaultP env (path ++ [normalizeName cmd]) (infoParser parseri) }
-#if MIN_VERSION_optparse_applicative(0,13,0)
-     in  OptP (Option (CmdReader Nothing cmds (`M.lookup` cmdMap)) props)
-#else
      in  OptP (Option (CmdReader cmds (`M.lookup` cmdMap)) props)
-#endif
   | (Option (OptReader names (CReader _ rdr) _) _) <- o =
-     p <|> either (const empty)
+     p <|> either' (const empty) pure (msum $ map (rdr <=< (maybe (left $ ErrorMsg "Missing environment variable") right . getEnvValue env path)) names)
-                  pure
-                  (runExcept . msum $
-                    map (maybe (throwE $ ErrorMsg "Missing environment variable")
-                               (runReaderT (unReadM rdr))
-                          . getEnvValue env path)
-                        names)
   | (Option (FlagReader names a) _) <- o =
      p <|> if any ((==Just "1") . getEnvValue env path) names then pure a else empty
   | otherwise = p
+  where
+#if MIN_VERSION_optparse_applicative(0,6,0)
+    right= ReadM . Right
+    left = ReadM . Left
+    either' f g (ReadM x) = either f g x
+#else
+    right = Right
+    left = Left
+    either' = either
+#endif
 injectDefaultP env path (MultP p1 p2) =
    MultP (injectDefaultP env path p1) (injectDefaultP env path p2)
 injectDefaultP env path (AltP p1 p2) =
    AltP (injectDefaultP env path p1) (injectDefaultP env path p2)
 injectDefaultP _env _path b@(BindP {}) = b
 
+
 getEnvValue :: M.Map [String] String -> [String] -> OptName -> Maybe String
 getEnvValue env path (OptLong l) = M.lookup (path ++ [normalizeName l]) env
 getEnvValue _ _ _                = Nothing

yesod-bin/README.md

@@ -1,111 +0,0 @@
-## yesod-bin: the Yesod executable
-
-This executable is almost exclusively used for its `yesod devel`
-capabilities, providing a development server for web apps. It also
-provides some legacy functionality, almost all of which has been
-superceded by functionality in the
-[Haskell Stack build tool](http://haskellstack.org/). This README will
-speak exclusively about `yesod devel`.
-
-__CAVEAT__ There may be some issues using `yesod devel` in Docker-enabled
-projects. See [comment on
-Github](https://github.com/yesodweb/yesod/pull/1305#issuecomment-263204471).
-
-### Development server
-
-The development server will automatically recompile your application
-whenever you make source code changes. It will then launch your app,
-and reverse-proxy to it. The reverse proxying ensures that you can
-connect to your application on a dedicated port, always get the latest
-version available, and won't get dropped connections when the app
-isn't yet ready. Instead, you'll get some very motivating messages:
-
-![Motivation](https://i.sli.mg/nO6DvN.png)
-
-## Common workflows
-
-The standard Yesod scaffoldings are configured to work with `yesod
-devel` out of the box (though see below for non-Yesod
-development). For the most part, from within your application
-directory, you'll just want to run:
-
-* `stack build yesod-bin`
-* `stack exec -- yesod devel`
-
-This will install the corresponding version of the `yesod` executable
-into your currently selected snapshot, and then use that
-executable. (Starting with version 1.5.0, you can be more lax and use
-a `yesod` executable compiled for a different snapshot. Once 1.5.0 is
-more widespread we'll probably update these instructions.)
-
-Some other common questions:
-
-* If you want to control which port you can access your application
-  on, use the `--port` command line option, e.g. `stack exec -- yesod
-  devel --port 4000`. Changing your port inside your source code _will
-  not work_, because you need to change the reverse proxying port.
-* If you want to run a command after each successful build, you can
-  use `stack exec -- yesod devel --success-hook "echo Yay!"`
-* If for some reason you want to disable the reverse proxy
-  capabilities, use `stack exec -- yesod devel
-  --disable-reverse-proxy`
-
-## How it works
-
-The workflow of the devel server is pretty simple:
-
-* Launch a reverse proxy server
-* Use Stack file-watch capability to run a build loop on your code,
-  rebuilding each time a file is modified
-* Have Stack call `yesod devel-signal` to write to a specific file
-  (`yesod-devel/rebuild`) each time a rebuild is successful
-* Each time `yesod-devel/rebuild` is modified:
-  * Kill the current child process
-  * Get a new random port
-  * Tell the reverse proxy server about the new port to forward to
-  * Run the application's devel script with two environment variables
-    set:
-    * `PORT` gives the newly generated random port. The application
-      needs to listen on that port.
-    * `DISPLAY_PORT` gives the port that the reverse proxy is
-      listening on, used for display purposes or generating URLs.
-
-Now some weird notes:
-
-* The devel script can be one of the following three files. `yesod
-  devel` will search for them in the given order. That script must
-  provide a `main` function.
-  * `app/devel.hs`
-  * `devel.hs`
-  * `src/devel.hs`
-* Unfortunately, directly killing the `ghc` interpreter has never
-  worked reliably, so we have an extra hack: when killing the process,
-  `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
-  the name `library-only`).
-
-If that all seems a little complicated, remember that the Yesod
-scaffolding handles all of this for you. But if you want to implement
-it yourself...
-
-## Non-Yesod development
-
-If you'd like to use the `yesod devel` server for your non-Yesod
-application, or even for a Yesod application not based on the
-scaffolding, this section is for you! We've got a
-[sample application in the repository](https://github.com/yesodweb/yesod/tree/master/yesod-bin/devel-example)
-that demonstrates how to get this set up. It demonstrates a good way
-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
-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
-shows.

yesod-bin/Scaffolding/Scaffolder.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Scaffolding.Scaffolder (scaffold) where
+
+import           Control.Arrow         ((&&&))
+import qualified Data.ByteString.Char8 as S
+import           Data.Conduit          (yield, ($$), ($$+-))
+import Control.Monad.Trans.Resource (runResourceT)
+import           Data.FileEmbed        (embedFile)
+import           Data.String           (fromString)
+import qualified Data.Text             as T
+import qualified Data.Text.Lazy        as LT
+import qualified Data.Text.Lazy.IO     as TLIO
+import           Text.ProjectTemplate  (unpackTemplate, receiveFS)
+import           System.IO
+import           Text.Shakespeare.Text (renderTextUrl, textFile)
+import Network.HTTP.Conduit (withManager, http, parseUrl, responseBody)
+import           Data.Maybe            (isJust)
+import           Distribution.Text     (simpleParse)
+import           Distribution.Package  (PackageName)
+
+prompt :: (String -> Maybe a) -> IO a
+prompt f = do
+    s <- getLine
+    case f s of
+        Just a -> return a
+        Nothing -> do
+            putStr "That was not a valid entry, please try again: "
+            hFlush stdout
+            prompt f
+
+data Backend = Sqlite
+             | Postgresql
+             | PostgresqlFay
+             | Mysql
+             | MongoDB
+             | Simple
+  deriving (Eq, Read, Show, Enum, Bounded)
+
+puts :: LT.Text -> IO ()
+puts s = TLIO.putStr (LT.init s) >> hFlush stdout
+
+backends :: [Backend]
+backends = [minBound .. maxBound]
+
+showBackend :: Backend -> String
+showBackend Sqlite = "s"
+showBackend Postgresql = "p"
+showBackend PostgresqlFay = "pf"
+showBackend Mysql = "mysql"
+showBackend MongoDB = "mongo"
+showBackend Simple = "simple"
+
+readBackend :: String -> Maybe Backend
+readBackend s = lookup s $ map (showBackend &&& id) backends
+
+backendBS :: Backend -> S.ByteString
+backendBS Sqlite = $(embedFile "hsfiles/sqlite.hsfiles")
+backendBS Postgresql = $(embedFile "hsfiles/postgres.hsfiles")
+backendBS PostgresqlFay = $(embedFile "hsfiles/postgres-fay.hsfiles")
+backendBS Mysql = $(embedFile "hsfiles/mysql.hsfiles")
+backendBS MongoDB = $(embedFile "hsfiles/mongo.hsfiles")
+backendBS Simple = $(embedFile "hsfiles/simple.hsfiles")
+
+validPackageName :: String -> Bool
+validPackageName s = isJust (simpleParse s :: Maybe PackageName)
+
+scaffold :: Bool -- ^ bare directory instead of a new subdirectory?
+         -> IO ()
+scaffold isBare = do
+    puts $ renderTextUrl undefined $(textFile "input/welcome.cg")
+    project <- prompt $ \s ->
+        if validPackageName s && s /= "test"
+            then Just s
+            else Nothing
+    let dir = project
+
+    puts $ renderTextUrl undefined $(textFile "input/database.cg")
+
+    ebackend' <- prompt $ \s -> if s == "url" then Just (Left ()) else fmap Right $ readBackend s
+
+    ebackend <-
+        case ebackend' of
+            Left () -> do
+                puts "Please enter the URL:  "
+                fmap Left $ prompt parseUrl
+            Right backend -> return $ Right backend
+
+    putStrLn "That's it! I'm creating your files now..."
+
+    let sink = unpackTemplate
+                (receiveFS $ if isBare then "." else fromString project)
+                (T.replace "PROJECTNAME" (T.pack project))
+    case ebackend of
+        Left req -> withManager $ \m -> do
+            res <- http req m
+            responseBody res $$+- sink
+        Right backend -> runResourceT $ yield (backendBS backend) $$ sink
+
+    TLIO.putStr $ LT.replace "PROJECTNAME" (LT.pack project) $ renderTextUrl undefined $(textFile "input/done.cg")

yesod-bin/certificate.pem

@@ -1,15 +0,0 @@
------BEGIN CERTIFICATE-----
-MIICWDCCAcGgAwIBAgIJAJG1ZMlcMDW6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV
-BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX
-aWRnaXRzIFB0eSBMdGQwHhcNMTExMDIyMTk0MjU3WhcNMTExMTIxMTk0MjU3WjBF
-MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50
-ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB
-gQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCdthgTK66SPXkx
-EXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cDJSSGK11eQEVs
-+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQABo1AwTjAdBgNV
-HQ4EFgQUaA6FbOj/0VJMb4egNyIDZ/ZNV/YwHwYDVR0jBBgwFoAUaA6FbOj/0VJM
-b4egNyIDZ/ZNV/YwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQUFAAOBgQCTQyOk
-D86Z+yzedXjTLI6FT8QugmQne1YQ8P0w37P76z2reagSvNee2e9B1oTHoPeKZMs0
-k99oS9yJ/NOQ1Ms90P+q0yBVGxAs/gF65qKgE27YGXzNtNobj/D4OoxcFG+BsORw
-VvYSBV4FiVy9RwJsr7AMqkUBcOEPCuJHgTx58w==
------END CERTIFICATE-----

yesod-bin/devel-example/.gitignore

@@ -1 +0,0 @@
-yesod-devel/

yesod-bin/devel-example/README.md

@@ -1,5 +0,0 @@
-An example non-Yesod application that is compatible with `yesod devel`. Steps
-to use it:
-
-* `stack build yesod-bin`
-* `stack exec -- yesod devel`

yesod-bin/devel-example/Setup.hs

@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain

yesod-bin/devel-example/app/Main.hs

@@ -1,6 +0,0 @@
-module Main where
-
-import DevelExample
-
-main :: IO ()
-main = prodMain

yesod-bin/devel-example/app/devel.hs

@@ -1,5 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-import "devel-example" DevelExample (develMain)
-
-main :: IO ()
-main = develMain

yesod-bin/devel-example/devel-example.cabal

@@ -1,30 +0,0 @@
-name:                devel-example
-version:             0.1.0.0
-build-type:          Simple
-cabal-version:       >=1.10
-
-flag library-only
-  default: False
-  description: Do not build the executable
-
-library
-  hs-source-dirs:      src
-  exposed-modules:     DevelExample
-  build-depends:       base
-                     , async
-                     , directory
-                     , http-types
-                     , wai
-                     , wai-extra
-                     , warp
-  default-language:    Haskell2010
-
-executable devel-example
-  hs-source-dirs:      app
-  main-is:             Main.hs
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
-  build-depends:       base
-                     , devel-example
-  default-language:    Haskell2010
-  if flag(library-only)
-    buildable:         False

yesod-bin/devel-example/src/DevelExample.hs

@@ -1,47 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module DevelExample
-    ( prodMain
-    , develMain
-    ) where
-
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async (race_)
-import Network.HTTP.Types
-import Network.Wai
-import Network.Wai.Handler.Warp
-import Network.Wai.Middleware.RequestLogger
-import System.Directory (doesFileExist)
-import System.Environment
-
-myApp :: Application
-myApp _req send = send $ responseLBS
-    status200
-    [(hContentType, "text/html; charset=utf-8")]
-    "<p>Well, this is really <b>boring</b>.</p>"
-
-prodMain :: IO ()
-prodMain = do
-    putStrLn "Running in production mode on port 8080"
-    run 8080 $ logStdout myApp
-
-develMain :: IO ()
-develMain = race_ watchTermFile $ do
-    port <- fmap read $ getEnv "PORT"
-    displayPort <- getEnv "DISPLAY_PORT"
-    putStrLn $ "Running in development mode on port " ++ show port
-    putStrLn $ "But you should connect to port " ++ displayPort
-    run port $ logStdoutDev myApp
-
--- | Would certainly be more efficient to use fsnotify, but this is
--- simpler.
-watchTermFile :: IO ()
-watchTermFile =
-    loop
-  where
-    loop = do
-        exists <- doesFileExist "yesod-devel/devel-terminate"
-        if exists
-            then return ()
-            else do
-                threadDelay 100000
-                loop

yesod-bin/devel-example/stack.yaml

@@ -1,8 +0,0 @@
-resolver: lts-7.10
-
-packages:
-- .
-- ..
-
-extra-deps:
-- typed-process-0.1.0.0

yesod-bin/ghcwrapper.hs

@@ -0,0 +1,60 @@
+{-
+  wrapper executable that captures arguments to ghc, ar or ld
+-}
+
+{-# LANGUAGE CPP #-}
+module Main where
+
+import           Control.Monad                     (when)
+import           Data.Maybe                        (fromMaybe)
+
+import           Distribution.Compiler             (CompilerFlavor (..))
+import           Distribution.Simple.Configure     (configCompiler)
+import           Distribution.Simple.Program       (arProgram,
+                                                    defaultProgramConfiguration,
+                                                    ghcProgram, ldProgram,
+                                                    programPath)
+import           Distribution.Simple.Program.Db    (configureAllKnownPrograms,
+                                                    lookupProgram)
+import           Distribution.Simple.Program.Types (Program (..))
+import           Distribution.Verbosity            (silent)
+
+import           System.Directory                  (doesDirectoryExist)
+import           System.Environment                (getArgs)
+import           System.Exit                       (ExitCode (..), exitWith)
+import           System.IO                         (hPutStrLn, stderr)
+import           System.Process                    (rawSystem, readProcess)
+
+
+#ifdef LDCMD
+cmd :: Program
+cmd = ldProgram
+outFile = "yesod-devel/ldargs.txt"
+#else
+#ifdef ARCMD
+cmd :: Program
+cmd = arProgram
+outFile ="yesod-devel/arargs.txt"
+#else
+cmd :: Program
+cmd = ghcProgram
+outFile = "yesod-devel/ghcargs.txt"
+#endif
+#endif
+
+runProgram :: Program -> [String] -> IO ExitCode
+runProgram pgm args = do
+  (comp, pgmc) <- configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration silent
+  pgmc' <- configureAllKnownPrograms silent pgmc
+  case lookupProgram pgm pgmc' of
+    Nothing -> do
+      hPutStrLn stderr ("cannot find program '" ++ programName pgm ++ "'")
+      return (ExitFailure 1)
+    Just p -> rawSystem (programPath p) args
+
+main = do
+  args <- getArgs
+  e <- doesDirectoryExist "yesod-devel"
+  when e $ writeFile outFile (show args ++ "\n")
+  ex <- runProgram cmd args
+  exitWith ex

yesod-bin/input/database.cg

@@ -0,0 +1,13 @@
+Yesod uses Persistent for its (you guessed it) persistence layer.
+This tool will build in either SQLite or PostgreSQL or MongoDB support for you.
+We recommend starting with SQLite: it has no dependencies.
+
+    s      = sqlite
+    p      = postgresql
+    pf     = postgresql + Fay (experimental)
+    mongo  = mongodb
+    mysql  = MySQL
+    simple = no database, no auth
+    url    = Let me specify URL containing a site (advanced)
+
+So, what'll it be? 

yesod-bin/input/done.cg

@@ -0,0 +1,27 @@
+
+---------------------------------------
+
+                     ___
+                            {-)   |\
+                       [m,].-"-.   /
+      [][__][__]         \(/\__/\)/
+      [__][__][__][__]~~~~  |  |
+      [][__][__][__][__][] /   |
+      [__][__][__][__][__]| /| |
+      [][__][__][__][__][]| || |  ~~~~
+  ejm [__][__][__][__][__]__,__,  \__/
+
+
+---------------------------------------
+
+The foundation for your web application has been built.
+
+
+There are a lot of resources to help you use Yesod.
+Start with the book: http://www.yesodweb.com/book
+Take part in the community: http://yesodweb.com/page/community
+
+
+Start your project:
+
+   cd PROJECTNAME && cabal sandbox init && cabal install --enable-tests . yesod-platform yesod-bin --max-backjumps=-1 --reorder-goals && yesod devel

yesod-bin/input/welcome.cg

@@ -0,0 +1,6 @@
+Welcome to the Yesod scaffolder.
+I'm going to be creating a skeleton Yesod project for you.
+
+What do you want to call your project? We'll use this for the cabal name.
+
+Project name: 

yesod-bin/key.pem

@@ -1,15 +0,0 @@
------BEGIN RSA PRIVATE KEY-----
-MIICXAIBAAKBgQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCd
-thgTK66SPXkxEXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cD
-JSSGK11eQEVs+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQAB
-AoGAR8pgAgjo7tZ60ccIUjOX/LSxB6d5J2Eu6wvNjk6qZD9OuWtOa7up/HigmZ63
-CDMjQNI2/o6AOrWtEQkPYZNbibuifzg5V517nHGSqkqjoIgesAiwEsoKpeOgGTtM
-MM08oHbJ9uOnDnEEnDBiE0iE3jCTDfmwjqDMpUhu9dZ1EAECQQDKVpzSSV3pzMOp
-ixNxMpYxzcE+4K9jgM+MlxPBJSQhVrg/cRQWb26cKBi8LdSxF23hQTsFr+8qLwid
-Ah2AgUOBAkEAyaaCjrNRCiHRpd6YzWZ6GKkxbUvxSuOKX3N7hDaE2OFzQTv2Li8B
-5mrCsXnSZtOG+MBFdHU66UYie1OzDSDKtwJAKMsvkOID0ihbZmpIwDC/wUjHZkLs
-eXY14hVvgShY0XPnb7r/nspWlZsr6Xyf/hhIKfr5yFrBMFMNPIJ5qjflgQJAWsyV
-YTgxN4S+6BdxapvIQq58ySA3CGeo+Q4BAimibB4oTal4UpdsHZrZDB00toRs9Dlv
-jN70pfGkuS+ZIkIvxQJBAKSf5qpXWp4oZcThkieAiMeAhG96xqRPXhPUxq6QF+YG
-T4PF1sjlpZwqy7C+2oF3BqLP09mCW7YkH9Jgnl1zDF8=
------END RSA PRIVATE KEY-----

yesod-bin/main.hs

@@ -1,19 +1,42 @@
 {-# LANGUAGE CPP             #-}
 {-# 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.Exit            (ExitCode (ExitSuccess), exitWith)
+import           System.Process         (rawSystem)
 
 import           AddHandler             (addHandler)
-import           Devel                  (DevelOpts (..), devel, develSignal)
+import           Devel                  (DevelOpts (..), devel, DevelTermOpt(..))
 import           Keter                  (keter)
 import           Options                (injectDefaults)
 import qualified Paths_yesod_bin
+import           Scaffolding.Scaffolder
+
+#if MIN_VERSION_optparse_applicative(0,6,0)
+import           Options.Applicative.Types (ReadM (ReadM))
+#else
+import           Options.Applicative.Builder.Internal (Mod, OptionFields)
+#endif
 
 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)
 
@@ -24,32 +47,26 @@ data Options = Options
                }
   deriving (Show, Eq)
 
-data Command = Init [String]
+data Command = Init { _initBare :: Bool }
              | HsFiles
              | Configure
              | Build { buildExtraArgs   :: [String] }
              | Touch
-             | Devel { develSuccessHook :: Maybe String
+             | Devel { _develDisableApi  :: Bool
-                     , develExtraArgs   :: [String]
+                     , _develSuccessHook :: Maybe String
-                     , develPort        :: Int
+                     , _develFailHook    :: Maybe String
-                     , develTlsPort     :: Int
+                     , _develRescan      :: Int
-                     , proxyTimeout     :: Int
+                     , _develBuildDir    :: Maybe String
-                     , noReverseProxy   :: Bool
+                     , develIgnore       :: [String]
-                     , develHost        :: Maybe String
+                     , develExtraArgs    :: [String]
-                     , cert             :: Maybe (FilePath, FilePath)
+                     , _develPort        :: Int
+                     , _proxyTimeout     :: Int
+                     , _noReverseProxy   :: Bool
+                     , _interruptOnly    :: Bool
                      }
-             | DevelSignal
              | Test
              | AddHandler
-                    { addHandlerRoute   :: Maybe String
+             | Keter { _keterNoRebuild :: Bool }
-                    , addHandlerPattern :: Maybe String
-                    , addHandlerMethods :: [String]
-                    }
-             | Keter
-                    { _keterNoRebuild :: Bool
-                    , _keterNoCopyTo  :: Bool
-                    , _keterBuildArgs :: [String]
-                    }
              | Version
   deriving (Show, Eq)
 
@@ -67,50 +84,40 @@ main = do
                     d@Devel{} -> d { develExtraArgs = args }
                     c -> c
                 })
+         , ("yesod.devel.ignore"        , \o args -> o { optCommand =
+                case optCommand o of
+                    d@Devel{} -> d { develIgnore = args }
+                    c -> c
+                })
          , ("yesod.build.extracabalarg" , \o args -> o { optCommand =
                 case optCommand o of
                     b@Build{} -> b { buildExtraArgs = args }
                     c -> c
                 })
          ] optParser'
+  let cabal = rawSystem' (cabalCommand o)
   case optCommand o of
-    Init _          -> initErrorMsg
+    Init bare       -> scaffold bare
     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
+    Keter noRebuild -> keter (cabalCommand o) noRebuild
     Version         -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
-    AddHandler{..}  -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods
+    AddHandler      -> addHandler
-    Test            -> cabalErrorMsg
+    Test            -> cabalTest cabal
-    Devel{..}       -> devel DevelOpts
+    Devel{..}       -> devel (DevelOpts
-                             { verbose      = optVerbose o
+                              (optCabalPgm o == CabalDev) _develDisableApi (optVerbose o)
-                             , successHook  = develSuccessHook
+                              _develRescan _develSuccessHook _develFailHook
-                             , develPort    = develPort
+                              _develBuildDir _develPort _proxyTimeout
-                             , develTlsPort = develTlsPort
+                              (not _noReverseProxy)
-                             , proxyTimeout = proxyTimeout
+                              (if _interruptOnly then TerminateOnlyInterrupt else TerminateOnEnter )
-                             , useReverseProxy = not noReverseProxy
+                           ) develExtraArgs
-                             , develHost    = develHost
-                             , cert         = cert
-                             } develExtraArgs
-    DevelSignal     -> develSignal
   where
-    initErrorMsg = do
+    cabalTest cabal = do touch'
-        mapM_ putStrLn
+                         _ <- cabal ["configure", "--enable-tests", "-flibrary-only"]
-            [ "The init command has been removed."
+                         _ <- cabal ["build"]
-            , "Please use 'stack new <project name> <template>' instead where the"
+                         cabal ["test"]
-            , "available templates can be found by running 'stack templates'. For"
-            , "a Yesod based application you should probably choose one of the"
-            , "pre-canned Yesod templates."
-            ]
-        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" )
@@ -119,82 +126,75 @@ optParser :: Parser Options
 optParser = Options
         <$> flag Cabal CabalDev ( long "dev"     <> short 'd' <> help "use cabal-dev" )
         <*> switch              ( long "verbose" <> short 'v' <> help "More verbose output" )
-        <*> subparser ( command "init"         (info (helper <*> initOptions)
+        <*> subparser ( command "init"
-                            (progDesc "Command no longer available, please use 'stack new'"))
+                            (info (Init <$> (switch (long "bare" <> help "Create files in current folder")))
+                            (progDesc "Scaffold a new site"))
                       <> 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))
+                      <> command "build"     (info (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)
+                      <> command "devel"     (info 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)
+                      <> command "add-handler" (info (pure AddHandler)
-                            (progDesc ("Add a new handler and module to the project."
+                            (progDesc "Add a new handler and module to the project"))
-                            ++ " Interactively asks for input if you do not specify arguments.")))
+                      <> command "keter"       (info keterOptions
-                      <> command "keter"       (info (helper <*> keterOptions)
                             (progDesc "Build a keter bundle"))
                       <> command "version"     (info (pure Version)
                             (progDesc "Print the version of Yesod"))
                       )
 
-initOptions :: Parser Command
-initOptions = Init <$> many (argument str mempty)
-
 keterOptions :: Parser Command
-keterOptions = Keter
+keterOptions = Keter <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebuilding" )
-    <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebuilding" )
-    <*> switch ( long "nocopyto" <> help "Ignore copy-to directive in keter config file" )
-    <*> optStrToList ( long "build-args" <> help "Build arguments" )
-  where
-    optStrToList m = option (words <$> str) $ value [] <> m
 
 develOptions :: Parser Command
-develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
+develOptions = Devel <$> switch ( long "disable-api"  <> short 'd'
+                            <> help "Disable fast GHC API rebuilding")
+                     <*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
                             <> help "Run COMMAND after rebuild succeeds")
-                     <*> extraStackArgs
+                     <*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND"
-                     <*> option auto ( long "port" <> short 'p' <> value 3000 <> metavar "N"
+                            <> help "Run COMMAND when rebuild fails")
+                     <*> option ( long "event-timeout" <> short 't' <> value 1 <> metavar "N"
+                            <> help "Force rescan of files every N seconds" )
+                     <*> optStr ( long "builddir" <> short 'b'
+                            <> help "Set custom cabal build directory, default `dist'")
+                     <*> many ( strOption ( long "ignore" <> short 'i' <> metavar "DIR"
+                                   <> help "ignore file changes in DIR" )
+                              )
+                     <*> extraCabalArgs
+                     <*> option ( long "port" <> short 'p' <> value 3000 <> metavar "N"
                             <> help "Devel server listening port" )
-                     <*> option auto ( long "tls-port" <> short 'q' <> value 3443 <> metavar "N"
+                     <*> option ( long "proxy-timeout" <> short 'x' <> value 0 <> metavar "N"
-                            <> help "Devel server listening port (tls)" )
-                     <*> option auto ( long "proxy-timeout" <> short 'x' <> value 0 <> metavar "N"
                             <> help "Devel server timeout before returning 'not ready' message (in seconds, 0 for none)" )
                      <*> switch ( long "disable-reverse-proxy" <> short 'n'
                             <> help "Disable reverse proxy" )
-                     <*> optStr (long "host" <> metavar "HOST"
+                     <*> switch ( long "interrupt-only"  <> short 'c'
-                            <> help "Host interface to bind to; IP address, '*' for all interfaces, '*4' for IP4, '*6' for IP6")
+                            <> help "Disable exiting when enter is pressed")
-                     <*> 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"
-                                   <> help "pass extra argument ARG to stack")
-                      )
 
 extraCabalArgs :: Parser [String]
 extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG"
                                    <> help "pass extra argument ARG to cabal")
                       )
 
-addHandlerOptions :: Parser Command
-addHandlerOptions = AddHandler
-    <$> optStr ( long "route" <> short 'r' <> metavar "ROUTE"
-           <> help "Name of route (without trailing R). Required.")
-    <*> optStr ( long "pattern" <> short 'p' <> metavar "PATTERN"
-           <> help "Route pattern (ex: /entry/#EntryId). Defaults to \"\".")
-    <*> many (strOption ( long "method" <> short 'm' <> metavar "METHOD"
-                 <> help "Takes one method. Use this multiple times to add multiple methods. Defaults to none.")
-             )
-
 -- | Optional @String@ argument
 optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
-optStr m = option (Just <$> str) $ value Nothing <> m
+optStr m =
+    nullOption $ value Nothing <> reader (success . str)  <> m
+  where
+#if MIN_VERSION_optparse_applicative(0,6,0)
+    success = ReadM . Right
+#else
+    success = Right
+#endif
+
+-- | 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,71 +1,106 @@
 name:            yesod-bin
-version:         1.6.2.2
+version:         1.2.11
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
 maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        The yesod helper executable.
-description:     See README.md for more information
+description:     Provides scaffolding, devel server, and some simple code generation helpers.
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.10
+cabal-version:   >= 1.6
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
+data-files:      refreshing.html
 
 extra-source-files:
-  README.md
+  input/*.cg
-  ChangeLog.md
+  hsfiles/mongo.hsfiles
-  refreshing.html
+  hsfiles/mysql.hsfiles
-  *.pem
+  hsfiles/postgres.hsfiles
+  hsfiles/postgres-fay.hsfiles
+  hsfiles/simple.hsfiles
+  hsfiles/sqlite.hsfiles
+
+executable             yesod-ghc-wrapper
+    main-is: ghcwrapper.hs
+    build-depends:
+                    base                       >= 4         && < 5
+                  , Cabal
+
+executable             yesod-ld-wrapper
+    main-is: ghcwrapper.hs
+    cpp-options:     -DLDCMD
+    build-depends:
+                    base                       >= 4         && < 5
+                  , Cabal
+
+executable             yesod-ar-wrapper
+    main-is: ghcwrapper.hs
+    cpp-options:     -DARCMD
+    build-depends:
+                     base                       >= 4         && < 5
+                   , Cabal
 
 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
+                     , ghc                >= 7.0.3
-                     , bytestring         >= 0.9.1.4
+                     , ghc-paths          >= 0.1
-                     , conduit            >= 1.3
+                     , parsec             >= 2.1          && < 4
-                     , 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
+                     , shakespeare-text   >= 1.0
+                     , shakespeare        >= 1.0.2        && < 2.1
+                     , shakespeare-js     >= 1.0.2
+                     , shakespeare-css    >= 1.0.2
+                     , bytestring         >= 0.9.1.4
                      , time               >= 1.1.4
-                     , transformers
+                     , template-haskell
-                     , transformers-compat
+                     , directory          >= 1.0
-                     , unliftio
+                     , Cabal
+                     , unix-compat        >= 0.2          && < 0.5
+                     , containers         >= 0.2
+                     , attoparsec         >= 0.10
+                     , http-types         >= 0.7
+                     , blaze-builder      >= 0.2.1.4      && < 0.4
+                     , filepath           >= 1.1
+                     , process
+                     , zlib               >= 0.5          && < 0.6
+                     , tar                >= 0.4          && < 0.5
+                     , system-filepath    >= 0.4          && < 0.5
+                     , system-fileio      >= 0.3          && < 0.4
                      , unordered-containers
-                     , wai                >= 2.0
+                     , yaml               >= 0.8          && < 0.9
-                     , wai-extra
+                     , optparse-applicative >= 0.5
+                     , fsnotify           >= 0.0          && < 0.2
+                     , split              >= 0.2          && < 0.3
+                     , file-embed
+                     , conduit            >= 0.5          && < 1.2
+                     , conduit-extra
+                     , resourcet          >= 0.3          && < 1.2
+                     , base64-bytestring
+                     , lifted-base
+                     , http-reverse-proxy >= 0.1.1
+                     , network
+                     , http-conduit
+                     , network-conduit
+                     , project-template   >= 0.1.1
+                     , transformers
                      , warp               >= 1.3.7.5
-                     , warp-tls           >= 3.0.1
+                     , wai                >= 1.4
-                     , yaml               >= 0.8          && < 0.12
+                     , wai-extra
-                     , zlib               >= 0.5
+                     , data-default-class
-                     , aeson
+                     , streaming-commons
 
-    ghc-options:       -Wall -threaded -rtsopts
+    ghc-options:       -Wall -threaded -rtsopts -with-rtsopts=-I0
     main-is:           main.hs
-    other-modules:     Devel
+    other-modules:     Scaffolding.Scaffolder
+                       Devel
+                       Build
+                       GhcBuild
                        Keter
                        AddHandler
                        Paths_yesod_bin

yesod-core/ChangeLog.md

@@ -1,463 +0,0 @@
-# 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)
-
-## 1.4.37.1
-
-* Fix documentation on `languages` function, update `getMessageRender` to use said function. [#1457](https://github.com/yesodweb/yesod/pull/1457)
-
-## 1.4.37
-
-* Add `setWeakEtag` function in Yesod.Core.Handler module.
-
-## 1.4.36
-
-* Add `replaceOrAddHeader` function in Yesod.Core.Handler module. [1416](https://github.com/yesodweb/yesod/issues/1416)
-
-## 1.4.35.1
-
-* TH fix for GHC 8.2
-
-## 1.4.35
-
-* Contexts can be included in generated TH instances. [1365](https://github.com/yesodweb/yesod/issues/1365)
-* Type variables can be included in routes.
-
-## 1.4.34
-
-* Add `WaiSubsiteWithAuth`. [#1394](https://github.com/yesodweb/yesod/pull/1394)
-
-## 1.4.33
-
-* Adds curly brackets to route parser. [#1363](https://github.com/yesodweb/yesod/pull/1363)
-
-## 1.4.32
-
-* Fix warnings
-* Route parsing handles CRLF line endings
-* Add 'getPostParams' in Yesod.Core.Handler
-* Haddock rendering improved.
-
-## 1.4.31
-
-* Add `parseCheckJsonBody` and `requireCheckJsonBody`
-
-## 1.4.30
-
-* Add `defaultMessageWidget`
-
-## 1.4.29
-
-* Exports some internals and fix version bounds [#1318](https://github.com/yesodweb/yesod/pull/1318)
-
-## 1.4.28
-
-* Add ToWidget instances for strict text, lazy text, and text builder [#1310](https://github.com/yesodweb/yesod/pull/1310)
-
-## 1.4.27
-
-* Added `jsAttributes` [#1308](https://github.com/yesodweb/yesod/pull/1308)
-
-## 1.4.26
-
-* Modify `languages` so that, if you previously called `setLanguage`, the newly
-  set language will be reflected.
-
-## 1.4.25
-
-* Add instance of MonadHandler and MonadWidget for ExceptT [#1278](https://github.com/yesodweb/yesod/pull/1278)
-
-## 1.4.24
-
-* cached and cachedBy will not overwrite global state changes [#1268](https://github.com/yesodweb/yesod/pull/1268)
-
-## 1.4.23.1
-
-* Don't allow sending multiple cookies with the same name to the client, in accordance with [RFC 6265](https://tools.ietf.org/html/rfc6265). This fixes an issue where multiple CSRF tokens were sent to the client. [#1258](https://github.com/yesodweb/yesod/pull/1258)
-* Default CSRF tokens to the root path "/", fixing an issue where multiple tokens were stored in cookies, and using the wrong one led to CSRF errors [#1248](https://github.com/yesodweb/yesod/pull/1248)
-
-## 1.4.23
-
-* urlParamRenderOverride method for Yesod class [#1257](https://github.com/yesodweb/yesod/pull/1257)
-* Add laxSameSiteSessions and strictSameSiteSessions [#1226](https://github.com/yesodweb/yesod/pull/1226)
-
-## 1.4.22
-
-* Proper handling of impure exceptions within `HandlerError` values
-
-## 1.4.21
-
-* Add support for `Encoding` from `aeson-0.11` [#1241](https://github.com/yesodweb/yesod/pull/1241)
-
-## 1.4.20.2
-
-* GHC 8 support
-
-## 1.4.20.1
-
-* Log a warning when a CSRF error occurs [#1200](https://github.com/yesodweb/yesod/pull/1200)
-
-## 1.4.20
-
-* `addMessage`, `addMessageI`, and `getMessages` functions
-
-## 1.4.19.1
-
-* Allow lines of dashes in route files [#1182](https://github.com/yesodweb/yesod/pull/1182)
-
-## 1.4.19
-
-* Auth logout not working with defaultCsrfMiddleware [#1151](https://github.com/yesodweb/yesod/issues/1151)
-
-## 1.4.18.2
-
-* Allow subsites within hierarchical routes [#1144](https://github.com/yesodweb/yesod/pull/1144)
-
-## 1.4.18
-
-* Add hook to apply arbitrary function to all handlers [#1122](https://github.com/yesodweb/yesod/pull/1122)
-
-## 1.4.17
-
-* Add `getApprootText`
-
-## 1.4.16
-
-* Add `guessApproot` and `guessApprootOr`
-
-## 1.4.15.1
-
-* bugfix neverExpires leaked threads
-
-## 1.4.15
-
-* mkYesod avoids using reify when it isn't necessary. This avoids needing to define the site type below the call to mkYesod.
-
-## 1.4.14
-
-* Add CSRF protection functions and middleware based on HTTP cookies and headers [#1017](https://github.com/yesodweb/yesod/pull/1017)
-* Add mkYesodWith, which allows creating sites with polymorphic type parameters [#1055](https://github.com/yesodweb/yesod/pull/1055)
-* Do not define the site type below a call to mkYesod (or any variant), as it will be required at splicing time for reification.
-  This was allowed before because reification was not in use. Reification was introduced to allow parametrized types to be used
-  by mkYesod (and variants), with potentially polymorphic variables.
-
-## 1.4.13
-
-* Add getsYesod function [#1042](https://github.com/yesodweb/yesod/pull/1042)
-* Add IsString instance for WidgetT site m () [#1038](https://github.com/yesodweb/yesod/pull/1038)
-
-## 1.4.12
-
-* Don't show source location for logs that don't have that information [#1027](https://github.com/yesodweb/yesod/pull/1027)
-
-## 1.4.11
-
-* Expose `stripHandlerT` and `subHelper`
-
-## 1.4.10
-
-* Export log formatting [#1001](https://github.com/yesodweb/yesod/pull/1001)
-
-## 1.4.9.1
-
-* Deal better with multiple cookie headers
-
-## 1.4.9
-
-* Add simple authentication helpers [#962](https://github.com/yesodweb/yesod/pull/962)
-
-## 1.4.8.3
-
-* Use 307 redirect for cleaning paths and non-GET requests [#951](https://github.com/yesodweb/yesod/issues/951)
-
-## 1.4.8.2
-
-* Allow blaze-builder 0.4
-
-## 1.4.8.1
-
-* Bump upper bound on path-pieces
-
-## 1.4.8
-
-* Add a bunch of `Semigroup` instances
-
-## 1.4.7.3
-
-* Remove defunct reference to SpecialResponse [#925](https://github.com/yesodweb/yesod/issues/925)
-
-## 1.4.7
-
-SSL-only session security [#894](https://github.com/yesodweb/yesod/pull/894)
-
-## 1.4.6.2
-
-monad-control 1.0
-
-## 1.4.6
-
-Added the `Yesod.Core.Unsafe` module.
-
-## 1.4.5
-
-* `envClientSessionBackend`
-* Add `MonadLoggerIO` instances (conditional on monad-logger 0.3.10 being used).
-
-## 1.4.4.5
-
-Support time 1.5
-
-## 1.4.4.2
-
-`neverExpires` uses dates one year in the future (instead of in 2037).
-
-## 1.4.4.1
-
-Improvements to etag/if-none-match support #868 #869
-
-## 1.4.4
-
-Add the `notModified` and `setEtag` functions.
-
-## 1.4.3
-
-Switch to mwc-random for token generation.

yesod-core/README

@@ -0,0 +1 @@
+Learn more at http://www.yesodweb.com/

yesod-core/README.md

@@ -1,7 +0,0 @@
-## yesod-core
-
-This is the main package for Yesod, providing all core functionality on which
-other packages can be built. It provides dispatch, handler functions, widgets,
-etc.
-
-Yesod is well documented on [its website](http://www.yesodweb.com/).

yesod-core/Yesod/Core.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -18,7 +19,7 @@ module Yesod.Core
     , Approot (..)
     , FileUpload (..)
     , ErrorResponse (..)
-      -- * Utilities
+      -- * Utitlities
     , maybeAuthorized
     , widgetToPageContent
       -- * Defaults
@@ -29,10 +30,6 @@ module Yesod.Core
     , AuthResult (..)
     , unauthorizedI
       -- * Logging
-    , defaultMakeLogger
-    , defaultMessageLoggerSource
-    , defaultShouldLogIO
-    , formatLogMessage
     , LogLevel (..)
     , logDebug
     , logInfo
@@ -48,35 +45,22 @@ module Yesod.Core
     , SessionBackend (..)
     , customizeSessionCookies
     , defaultClientSessionBackend
-    , envClientSessionBackend
     , clientSessionBackend
-    , sslOnlySessions
-    , laxSameSiteSessions
-    , strictSameSiteSessions
-    , sslOnlyMiddleware
     , clientSessionDateCacher
     , loadClientSession
     , Header(..)
-    -- * CSRF protection
-    , defaultCsrfMiddleware
-    , defaultCsrfSetCookieMiddleware
-    , csrfSetCookieMiddleware
-    , defaultCsrfCheckMiddleware
-    , csrfCheckMiddleware
     -- * JS loaders
     , ScriptLoadPosition (..)
     , BottomOfHeadAsync
-    -- * Generalizing type classes
+      -- * Subsites
     , MonadHandler (..)
     , MonadWidget (..)
-      -- * Approot
+    , getRouteToParent
-    , guessApproot
+    , defaultLayoutSub
-    , guessApprootOr
-    , getApprootText
       -- * Misc
     , yesodVersion
     , yesodRender
-    , Yesod.Core.runFakeHandler
+    , runFakeHandler
       -- * LiteApp
     , module Yesod.Core.Internal.LiteApp
       -- * Low-level
@@ -92,7 +76,8 @@ module Yesod.Core
     , module Text.Blaze.Html
     , MonadTrans (..)
     , MonadIO (..)
-    , MonadUnliftIO (..)
+    , MonadBase (..)
+    , MonadBaseControl
     , MonadResource (..)
     , MonadLogger
       -- * Commonly referenced functions/datatypes
@@ -131,15 +116,17 @@ import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)
 import Control.Monad.Logger
 import Control.Monad.Trans.Class (MonadTrans (..))
 import Yesod.Core.Internal.Session
-import Yesod.Core.Internal.Run (yesodRunner, yesodRender)
+import Yesod.Core.Internal.Run (yesodRunner)
 import Yesod.Core.Class.Yesod
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Class.Breadcrumbs
-import qualified Yesod.Core.Internal.Run
+import Yesod.Core.Internal.Run (yesodRender, runFakeHandler)
 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
@@ -149,15 +136,6 @@ import Text.Lucius
 import Text.Julius
 import Network.Wai (Application)
 
-runFakeHandler :: (Yesod site, MonadIO m) =>
-                  SessionMap
-               -> (site -> Logger)
-               -> site
-               -> HandlerT site IO a
-               -> m (Either ErrorResponse a)
-runFakeHandler = Yesod.Core.Internal.Run.runFakeHandler
-{-# DEPRECATED runFakeHandler "import runFakeHandler from Yesod.Core.Unsafe" #-}
-
 -- | Return an 'Unauthorized' value, with the given i18n message.
 unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult
 unauthorizedI msg = do
@@ -179,6 +157,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,43 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# 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.Class.Yesod
+import Yesod.Core.Class.Handler
+import Yesod.Core.Internal.Run
+
+-- | 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 {..} req =
+        app req
+      where
+        WaiSubsite app = ysreGetSub $ yreSite $ ysreParentEnv
+
+-- | A helper function for creating YesodSubDispatch instances, used by the
+-- internal generated code.
+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,96 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Yesod.Core.Class.Handler
+    ( MonadHandler (..)
+    , MonadWidget (..)
+    ) where
+
+import Yesod.Core.Types
+import Data.Monoid (mempty)
+import Control.Monad (liftM)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase, ExceptionT (..))
+import Control.Monad.Trans.Class (lift)
+import Data.Monoid (Monoid)
+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.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(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)
+#if !MIN_VERSION_resourcet(1,1,0)
+GO(ExceptionT)
+#endif
+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(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)
+#if !MIN_VERSION_resourcet(1,1,0)
+GO(ExceptionT)
+#endif
+GO(Pipe l i o u)
+GO(ConduitM i o)
+#undef GO
+#undef GOX

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

@@ -0,0 +1,689 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE CPP               #-}
+module Yesod.Core.Class.Yesod where
+
+import           Control.Monad.Logger               (logErrorS)
+import           Yesod.Core.Content
+import           Yesod.Core.Handler
+
+import           Yesod.Routes.Class
+
+import           Blaze.ByteString.Builder           (Builder)
+import           Blaze.ByteString.Builder.Char.Utf8 (fromText)
+import           Control.Arrow                      ((***), second)
+import           Control.Monad                      (forM, when, void)
+import           Control.Monad.IO.Class             (MonadIO (liftIO))
+import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelOther),
+                                                     LogSource)
+import qualified Data.ByteString.Char8              as S8
+import qualified Data.ByteString.Lazy               as L
+import Data.Aeson (object, (.=))
+import           Data.List                          (foldl')
+import           Data.List                          (nub)
+import qualified Data.Map                           as Map
+import           Data.Maybe                         (fromMaybe)
+import           Data.Monoid
+import           Data.Text                          (Text)
+import qualified Data.Text                          as T
+import qualified Data.Text.Encoding                 as TE
+import qualified Data.Text.Encoding.Error           as TEE
+import           Data.Text.Lazy.Builder             (toLazyText)
+import           Data.Text.Lazy.Encoding            (encodeUtf8)
+import           Data.Word                          (Word64)
+import           Language.Haskell.TH.Syntax         (Loc (..))
+import           Network.HTTP.Types                 (encodePath)
+import qualified Network.Wai                        as W
+import           Data.Default                       (def)
+import           Network.Wai.Parse                  (lbsBackEnd,
+                                                     tempFileBackEnd)
+import           System.IO                          (stdout)
+#if MIN_VERSION_fast_logger(2, 0, 0)
+import           Network.Wai.Logger                 (ZonedDate, clockDateCacher)
+import           System.Log.FastLogger
+import qualified GHC.IO.FD
+#else
+import           System.Log.FastLogger.Date         (ZonedDate)
+import           System.Log.FastLogger              (LogStr (..), Logger,
+                                                     loggerDate, loggerPutStr,
+                                                     mkLogger)
+#endif
+import           Text.Blaze                         (customAttribute, textTag,
+                                                     toValue, (!))
+import           Text.Blaze                         (preEscapedToMarkup)
+import qualified Text.Blaze.Html5                   as TBH
+import           Text.Hamlet
+import           Text.Julius
+import qualified Web.ClientSession                  as CS
+import           Web.Cookie                         (parseCookies)
+import           Web.Cookie                         (SetCookie (..))
+import           Yesod.Core.Types
+import           Yesod.Core.Internal.Session
+import           Yesod.Core.Widget
+import Control.Monad.Trans.Class (lift)
+
+-- | Define settings for a Yesod applications. All methods have intelligent
+-- defaults, and therefore no implementation is required.
+class RenderRoute site => Yesod site where
+    -- | An absolute URL to the root of the application. Do not include
+    -- trailing slash.
+    --
+    -- Default value: 'ApprootRelative'. This is valid under the following
+    -- conditions:
+    --
+    -- * 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 = ApprootRelative
+
+    -- | Output error response pages.
+    --
+    -- Default value: 'defaultErrorHandler'.
+    errorHandler :: ErrorResponse -> HandlerT site IO TypedContent
+    errorHandler = defaultErrorHandler
+
+    -- | Applies some form of layout to the contents of a page.
+    defaultLayout :: WidgetT site IO () -> HandlerT site IO Html
+    defaultLayout w = do
+        p <- widgetToPageContent w
+        mmsg <- getMessage
+        giveUrlRenderer [hamlet|
+            $newline never
+            $doctype 5
+            <html>
+                <head>
+                    <title>#{pageTitle p}
+                    ^{pageHead p}
+                <body>
+                    $maybe msg <- mmsg
+                        <p .message>#{msg}
+                    ^{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
+
+    -- | Determine if a request is authorized or not.
+    --
+    -- Return 'Authorized' if the request is authorized,
+    -- 'Unauthorized' a message if unauthorized.
+    -- If authentication is required, return 'AuthenticationRequired'.
+    isAuthorized :: Route site
+                 -> Bool -- ^ is this a write request?
+                 -> HandlerT site IO AuthResult
+    isAuthorized _ _ = return Authorized
+
+    -- | Determines whether the current request is a write request. By default,
+    -- this assumes you are following RESTful principles, and determines this
+    -- from request method. In particular, all except the following request
+    -- methods are considered write: GET HEAD OPTIONS TRACE.
+    --
+    -- This function is used to determine if a request is authorized; see
+    -- 'isAuthorized'.
+    isWriteRequest :: Route site -> HandlerT site IO Bool
+    isWriteRequest _ = do
+        wai <- waiRequest
+        return $ W.requestMethod wai `notElem`
+            ["GET", "HEAD", "OPTIONS", "TRACE"]
+
+    -- | The default route for authentication.
+    --
+    -- Used in particular by 'isAuthorized', but library users can do whatever
+    -- they want with it.
+    authRoute :: site -> Maybe (Route site)
+    authRoute _ = Nothing
+
+    -- | A function used to clean up path segments. It returns 'Right' with a
+    -- clean path or 'Left' with a new set of pieces the user should be
+    -- redirected to. The default implementation enforces:
+    --
+    -- * No double slashes
+    --
+    -- * There is no trailing slash.
+    --
+    -- Note that versions of Yesod prior to 0.7 used a different set of rules
+    -- involing trailing slashes.
+    cleanPath :: site -> [Text] -> Either [Text] [Text]
+    cleanPath _ s =
+        if corrected == s
+            then Right $ map dropDash s
+            else Left corrected
+      where
+        corrected = filter (not . T.null) s
+        dropDash t
+            | T.all (== '-') t = T.drop 1 t
+            | otherwise = t
+
+    -- | Builds an absolute URL by concatenating the application root with the
+    -- pieces of a path and a query string, if any.
+    -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'.
+    joinPath :: site
+             -> T.Text -- ^ application root
+             -> [T.Text] -- ^ path pieces
+             -> [(T.Text, T.Text)] -- ^ query string
+             -> Builder
+    joinPath _ ar pieces' qs' =
+        fromText ar `mappend` encodePath pieces qs
+      where
+        pieces = if null pieces' then [""] else map addDash pieces'
+        qs = map (TE.encodeUtf8 *** go) qs'
+        go "" = Nothing
+        go x = Just $ TE.encodeUtf8 x
+        addDash t
+            | T.all (== '-') t = T.cons '-' t
+            | otherwise = t
+
+    -- | This function is used to store some static content to be served as an
+    -- external file. The most common case of this is stashing CSS and
+    -- JavaScript content in an external file; the "Yesod.Widget" module uses
+    -- this feature.
+    --
+    -- The return value is 'Nothing' if no storing was performed; this is the
+    -- default implementation. A 'Just' 'Left' gives the absolute URL of the
+    -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is
+    -- necessary when you are serving the content outside the context of a
+    -- Yesod application, such as via memcached.
+    addStaticContent :: Text -- ^ filename extension
+                     -> Text -- ^ mime-type
+                     -> L.ByteString -- ^ content
+                     -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
+    addStaticContent _ _ _ = return Nothing
+
+    -- | Maximum allowed length of the request body, in bytes.
+    --
+    -- If @Nothing@, no maximum is applied.
+    --
+    -- Default: 2 megabytes.
+    maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64
+    maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes
+
+    -- | Creates a @Logger@ to use for log messages.
+    --
+    -- Note that a common technique (endorsed by the scaffolding) is to create
+    -- a @Logger@ value and place it in your foundation datatype, and have this
+    -- method return that already created value. That way, you can use that
+    -- same @Logger@ for printing messages during app initialization.
+    --
+    -- Default: Sends to stdout and automatically flushes on each write.
+    makeLogger :: site -> IO Logger
+#if MIN_VERSION_fast_logger(2, 0, 0)
+    makeLogger _ = do
+#if MIN_VERSION_fast_logger(2, 1, 0)
+        loggerSet <- newLoggerSet defaultBufSize Nothing
+#else
+        loggerSet <- newLoggerSet defaultBufSize GHC.IO.FD.stdout
+#endif
+        (getter, _) <- clockDateCacher
+        return $! Logger loggerSet getter
+#else
+    makeLogger _ = mkLogger True stdout
+#endif
+
+    -- | Send a message to the @Logger@ provided by @getLogger@.
+    --
+    -- Default implementation: checks if the message should be logged using
+    -- 'shouldLog' and, if so, formats using 'formatLogMessage'.
+    messageLoggerSource :: site
+                        -> Logger
+                        -> Loc -- ^ position in source code
+                        -> LogSource
+                        -> LogLevel
+                        -> LogStr -- ^ message
+                        -> IO ()
+    messageLoggerSource a logger loc source level msg = do
+        sl <- shouldLogIO a source level
+        when sl $
+            formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger
+
+    -- | Where to Load sripts from. We recommend the default value,
+    -- 'BottomOfBody'.  Alternatively use the built in async yepnope loader:
+    --
+    -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js
+    --
+    -- Or write your own async js loader.
+    jsLoader :: site -> ScriptLoadPosition site
+    jsLoader _ = BottomOfBody
+
+    -- | 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
+    -- 'customizeSessionCookies'.
+    --
+    -- Default: Uses clientsession with a 2 hour timeout.
+    makeSessionBackend :: site -> IO (Maybe SessionBackend)
+    makeSessionBackend _ = fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile
+
+    -- | How to store uploaded files.
+    --
+    -- Default: When the request body is greater than 50kb, store in a temp
+    -- file. For chunked request bodies, store in a temp file. Otherwise, store
+    -- in memory.
+    fileUpload :: site -> W.RequestBodyLength -> FileUpload
+    fileUpload _ (W.KnownLength size)
+        | size <= 50000 = FileUploadMemory lbsBackEnd
+    fileUpload _ _ = FileUploadDisk tempFileBackEnd
+
+    -- | Should we log the given log source/level combination.
+    --
+    -- Default: Logs everything at or above 'logLevel'
+    shouldLog :: site -> LogSource -> LogLevel -> Bool
+    shouldLog _ _ level = level >= LevelInfo
+
+    -- | 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 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.
+    --
+    -- Default: the 'defaultYesodMiddleware' function.
+    --
+    -- Since: 1.1.6
+    yesodMiddleware :: ToTypedContent res => HandlerT site IO res -> HandlerT site IO res
+    yesodMiddleware = defaultYesodMiddleware
+
+-- | Default implementation of 'yesodMiddleware'. Adds the response header
+-- \"Vary: Accept, Accept-Language\" and performs authorization checks.
+--
+-- Since 1.2.0
+defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
+defaultYesodMiddleware handler = do
+    addHeader "Vary" "Accept, Accept-Language"
+    authorizationCheck
+    handler
+
+-- | Check if a given request is authorized via 'isAuthorized' and
+-- 'isWriteRequest'.
+--
+-- Since 1.2.0
+authorizationCheck :: Yesod site => HandlerT site IO ()
+authorizationCheck = do
+    getCurrentRoute >>= maybe (return ()) checkUrl
+  where
+    checkUrl url = do
+        isWrite <- isWriteRequest url
+        ar <- isAuthorized url isWrite
+        case ar of
+            Authorized -> return ()
+            AuthenticationRequired -> do
+                master <- getYesod
+                case authRoute master of
+                    Nothing -> void $ notAuthenticated
+                    Just url' -> do
+                      void $ selectRep $ do
+                          provideRepType typeHtml $ do
+                              setUltDestCurrent
+                              void $ redirect url'
+                          provideRepType typeJson $
+                              void $ notAuthenticated
+            Unauthorized s' -> permissionDenied s'
+
+-- | Convert a widget to a 'PageContent'.
+widgetToPageContent :: (Eq (Route site), Yesod site)
+                    => WidgetT site IO ()
+                    -> HandlerT site IO (PageContent (Route site))
+widgetToPageContent w = do
+    master <- getYesod
+    hd <- HandlerT return
+    ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd
+    let title = maybe mempty unTitle mTitle
+        scripts = runUniqueList scripts'
+        stylesheets = runUniqueList stylesheets'
+
+    render <- getUrlRenderParams
+    let renderLoc x =
+            case x of
+                Nothing -> Nothing
+                Just (Left s) -> Just s
+                Just (Right (u, p)) -> Just $ render u p
+    css <- forM (Map.toList style) $ \(mmedia, content) -> do
+        let rendered = toLazyText $ content render
+        x <- addStaticContent "css" "text/css; charset=utf-8"
+           $ encodeUtf8 rendered
+        return (mmedia,
+            case x of
+                Nothing -> Left $ preEscapedToMarkup rendered
+                Just y -> Right $ either id (uncurry render) y)
+    jsLoc <-
+        case jscript of
+            Nothing -> return Nothing
+            Just s -> do
+                x <- addStaticContent "js" "text/javascript; charset=utf-8"
+                   $ encodeUtf8 $ renderJavascriptUrl render s
+                return $ renderLoc x
+
+    -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing
+    -- the asynchronous loader means your page doesn't have to wait for all the js to load
+    let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
+        regularScriptLoad = [hamlet|
+            $newline never
+            $forall s <- scripts
+                ^{mkScriptTag s}
+            $maybe j <- jscript
+                $maybe s <- jsLoc
+                    <script src="#{s}">
+                $nothing
+                    <script>^{jelper j}
+        |]
+
+        headAll = [hamlet|
+            $newline never
+            \^{head'}
+            $forall s <- stylesheets
+                ^{mkLinkTag s}
+            $forall s <- css
+                $maybe t <- right $ snd s
+                    $maybe media <- fst s
+                        <link rel=stylesheet media=#{media} href=#{t}>
+                    $nothing
+                        <link rel=stylesheet href=#{t}>
+                $maybe content <- left $ snd s
+                    $maybe media <- fst s
+                        <style media=#{media}>#{content}
+                    $nothing
+                        <style>#{content}
+            $case jsLoader master
+              $of BottomOfBody
+              $of BottomOfHeadAsync asyncJsLoader
+                  ^{asyncJsLoader asyncScripts mcomplete}
+              $of BottomOfHeadBlocking
+                  ^{regularScriptLoad}
+        |]
+    let bodyScript = [hamlet|
+            $newline never
+            ^{body}
+            ^{regularScriptLoad}
+        |]
+
+    return $ PageContent title headAll $
+        case jsLoader master of
+            BottomOfBody -> bodyScript
+            _ -> body
+  where
+    renderLoc' render' (Local url) = render' url []
+    renderLoc' _ (Remote s) = s
+
+    addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)
+    mkScriptTag (Script loc attrs) render' =
+        foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()
+    mkLinkTag (Stylesheet loc attrs) render' =
+        foldl' addAttr TBH.link
+            ( ("rel", "stylesheet")
+            : ("href", renderLoc' render' loc)
+            : attrs
+            )
+
+    runUniqueList :: Eq x => UniqueList x -> [x]
+    runUniqueList (UniqueList x) = nub $ x []
+
+-- | The default error handler for 'errorHandler'.
+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
+        setTitle "Not Found"
+        toWidget [hamlet|
+            <h1>Not Found
+            <p>#{path'}
+        |]
+    provideRep $ return $ object ["message" .= ("Not Found" :: Text)]
+
+-- For API requests.
+-- For a user with a browser,
+-- if you specify an authRoute the user will be redirected there and
+-- this page will not be shown.
+defaultErrorHandler NotAuthenticated = selectRep $ do
+    provideRep $ defaultLayout $ do
+        setTitle "Not logged in"
+        toWidget [hamlet|
+            <h1>Not logged in
+            <p style="display:none;">Set the authRoute and the user will be redirected there.
+        |]
+
+    provideRep $ do
+        -- 401 *MUST* include a WWW-Authenticate header
+        -- however, there is no standard to indicate a redirection
+        --
+        -- change this to Basic or Digest if you allow those forms of authentications
+        addHeader "WWW-Authenticate" "RedirectJSON realm=\"application\", param=\"authentication_url\""
+
+        -- The client will just use the authentication_url in the JSON
+        site <- getYesod
+        rend <- getUrlRender
+        return $ object $ [
+          "message" .= ("Not logged in"::Text)
+          ] ++
+          case authRoute site of
+              Nothing -> []
+              Just url -> ["authentication_url" .= rend url]
+
+defaultErrorHandler (PermissionDenied msg) = selectRep $ do
+    provideRep $ defaultLayout $ do
+        setTitle "Permission Denied"
+        toWidget [hamlet|
+            <h1>Permission denied
+            <p>#{msg}
+        |]
+    provideRep $
+        return $ object $ [
+          "message" .= ("Permission Denied. " <> msg)
+          ]
+
+defaultErrorHandler (InvalidArgs ia) = selectRep $ do
+    provideRep $ defaultLayout $ do
+        setTitle "Invalid Arguments"
+        toWidget [hamlet|
+            <h1>Invalid Arguments
+            <ul>
+                $forall msg <- ia
+                    <li>#{msg}
+        |]
+    provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]
+defaultErrorHandler (InternalError e) = do
+    $logErrorS "yesod-core" e
+    selectRep $ do
+        provideRep $ defaultLayout $ do
+            setTitle "Internal Server Error"
+            toWidget [hamlet|
+                <h1>Internal Server Error
+                <pre>#{e}
+            |]
+        provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]
+defaultErrorHandler (BadMethod m) = selectRep $ do
+    provideRep $ defaultLayout $ do
+        setTitle"Bad Method"
+        toWidget [hamlet|
+            <h1>Method Not Supported
+            <p>Method <code>#{S8.unpack m}</code> not supported
+        |]
+    provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
+
+asyncHelper :: (url -> [x] -> Text)
+         -> [Script (url)]
+         -> Maybe (JavascriptUrl (url))
+         -> Maybe Text
+         -> (Maybe (HtmlUrl url), [Text])
+asyncHelper render scripts jscript jsLoc =
+    (mcomplete, scripts'')
+  where
+    scripts' = map goScript scripts
+    scripts'' =
+        case jsLoc of
+            Just s -> scripts' ++ [s]
+            Nothing -> scripts'
+    goScript (Script (Local url) _) = render url []
+    goScript (Script (Remote s) _) = s
+    mcomplete =
+        case jsLoc of
+            Just{} -> Nothing
+            Nothing ->
+                case jscript of
+                    Nothing -> Nothing
+                    Just j -> Just $ jelper j
+
+#if MIN_VERSION_fast_logger(2, 0, 0)
+formatLogMessage :: IO ZonedDate
+                 -> Loc
+                 -> LogSource
+                 -> LogLevel
+                 -> LogStr -- ^ message
+                 -> IO LogStr
+formatLogMessage getdate loc src level msg = do
+    now <- getdate
+    return $
+        toLogStr now `mappend`
+        " [" `mappend`
+        (case level of
+            LevelOther t -> toLogStr t
+            _ -> toLogStr $ drop 5 $ show level) `mappend`
+        (if T.null src
+            then mempty
+            else "#" `mappend` toLogStr src) `mappend`
+        "] " `mappend`
+        msg `mappend`
+        " @(" `mappend`
+        toLogStr (fileLocationToString loc) `mappend`
+        ")\n"
+#else
+formatLogMessage :: IO ZonedDate
+                 -> Loc
+                 -> LogSource
+                 -> LogLevel
+                 -> LogStr -- ^ message
+                 -> IO [LogStr]
+formatLogMessage getdate loc src level msg = do
+    now <- getdate
+    return
+        [ LB now
+        , LB " ["
+        , LS $
+            case level of
+                LevelOther t -> T.unpack t
+                _ -> drop 5 $ show level
+        , LS $
+            if T.null src
+                then ""
+                else "#" ++ T.unpack src
+        , LB "] "
+        , msg
+        , LB " @("
+        , LS $ fileLocationToString loc
+        , LB ")\n"
+        ]
+#endif
+
+-- | Customize the cookies used by the session backend.  You may
+-- use this function on your definition of 'makeSessionBackend'.
+--
+-- For example, you could set the cookie domain so that it
+-- would work across many subdomains:
+--
+-- @
+-- makeSessionBackend = fmap (customizeSessionCookie addDomain) ...
+--   where
+--     addDomain cookie = cookie { 'setCookieDomain' = Just \".example.com\" }
+-- @
+--
+-- Default: Do not customize anything ('id').
+customizeSessionCookies :: (SetCookie -> SetCookie) -> (SessionBackend -> SessionBackend)
+customizeSessionCookies customizeCookie backend = backend'
+  where
+    customizeHeader (AddCookie cookie) = AddCookie (customizeCookie cookie)
+    customizeHeader other              = other
+    customizeSaveSession = (fmap . fmap . fmap) customizeHeader
+    backend' =
+      backend {
+        sbLoadSession = \req ->
+          second customizeSaveSession `fmap` sbLoadSession backend req
+      }
+
+
+defaultClientSessionBackend :: Int -- ^ minutes
+                            -> FilePath -- ^ key file
+                            -> IO SessionBackend
+defaultClientSessionBackend minutes fp = do
+  key <- CS.getKey fp
+  let timeout = fromIntegral (minutes * 60)
+  (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
+  return $ clientSessionBackend key getCachedDate
+
+jsToHtml :: Javascript -> Html
+jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
+
+jelper :: JavascriptUrl url -> HtmlUrl url
+jelper = fmap jsToHtml
+
+left :: Either a b -> Maybe a
+left (Left x) = Just x
+left _ = Nothing
+
+right :: Either a b -> Maybe b
+right (Right x) = Just x
+right _ = Nothing
+
+clientSessionBackend :: CS.Key  -- ^ The encryption key
+                     -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
+                     -> SessionBackend
+clientSessionBackend key getCachedDate =
+  SessionBackend {
+    sbLoadSession = loadClientSession key getCachedDate "_SESSION"
+  }
+
+loadClientSession :: CS.Key
+                  -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
+                  -> S8.ByteString -- ^ session name
+                  -> W.Request
+                  -> IO (SessionMap, SaveSession)
+loadClientSession key getCachedDate sessionName req = load
+  where
+    load = do
+      date <- getCachedDate
+      return (sess date, save date)
+    sess date = fromMaybe Map.empty $ do
+      raw <- lookup "Cookie" $ W.requestHeaders req
+      val <- lookup sessionName $ parseCookies raw
+      let host = "" -- fixme, properly lock sessions to client address
+      decodeClientSession key date host val
+    save date sess' = do
+      -- We should never cache the IV!  Be careful!
+      iv <- liftIO CS.randomIV
+      return [AddCookie def
+          { setCookieName = sessionName
+          , setCookieValue = encodeClientSession key iv date host sess'
+          , setCookiePath = Just "/"
+          , setCookieExpires = Just (csdcExpires date)
+          , setCookieDomain = Nothing
+          , setCookieHttpOnly = True
+          }]
+        where
+          host = "" -- fixme, properly lock sessions to client address
+
+-- taken from file-location package
+-- turn the TH Loc loaction information into a human readable string
+-- leaving out the loc_end parameter
+fileLocationToString :: Loc -> String
+fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
+  ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
+  where
+    line = show . fst . loc_start
+    char = show . snd . loc_start

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,24 @@ 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 Control.Monad (liftM)
-import qualified Data.Text.Lazy as TL
+
-import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8)
+import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
+import Data.Monoid (mempty)
+
 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 qualified Data.Conduit.Internal as CI
+import Data.Conduit.Internal (ResumableSource (ResumableSource))
 
 import qualified Data.Aeson as J
+import Data.Aeson.Encode (fromValue)
+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,40 +92,33 @@ 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
 instance ToContent Javascript where
     toContent = toContent . toLazyText . unJavascript
 
-instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where
+instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
-    toContent src = ContentSource $ CI.ConduitT (CI.mapOutput toFlushBuilder src >>=)
-
-instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) 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 +127,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 +159,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
@@ -224,15 +216,18 @@ typeOctet = "application/octet-stream"
 -- For example, \"text/html; charset=utf-8\" is commonly used to specify the
 -- character encoding for HTML data. This function would return \"text/html\".
 simpleContentType :: ContentType -> ContentType
-simpleContentType = fst . B.break (== _semicolon)
+simpleContentType = fst . B.breakByte 59 -- 59 == ;
 
--- | 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.breakByte semicolon (tailEmpty sub))
   where
     tailEmpty x = if B.null x then "" else B.tail x
+    (main, sub) = B.breakByte slash ct
+    slash = 47
+    semicolon = 59
+
 
 instance HasContentType a => HasContentType (DontFullyEvaluate a) where
     getContentType = getContentType . liftM unDontFullyEvaluate
@@ -242,18 +237,12 @@ instance ToContent a => ToContent (DontFullyEvaluate a) where
 
 instance ToContent J.Value where
     toContent = flip ContentBuilder Nothing
-              . J.fromEncoding
+              . Blaze.fromLazyText
-              . J.toEncoding
+              . toLazyText
-
+              . fromValue
-instance ToContent J.Encoding where
-    toContent = flip ContentBuilder Nothing . J.fromEncoding
-
 instance HasContentType J.Value where
     getContentType _ = typeJson
 
-instance HasContentType J.Encoding where
-    getContentType _ = typeJson
-
 instance HasContentType Html where
     getContentType _ = typeHtml
 
@@ -279,8 +268,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
@@ -291,8 +278,6 @@ instance ToTypedContent RepXml where
     toTypedContent (RepXml c) = TypedContent typeXml c
 instance ToTypedContent J.Value where
     toTypedContent v = TypedContent typeJson (toContent v)
-instance ToTypedContent J.Encoding where
-    toTypedContent e = TypedContent typeJson (toContent e)
 instance ToTypedContent Html where
     toTypedContent h = TypedContent typeHtml (toContent h)
 instance ToTypedContent T.Text where
@@ -301,8 +286,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,25 +11,11 @@ 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 (..)
     , PathMultiPiece (..)
@@ -36,7 +23,6 @@ module Yesod.Core.Dispatch
       -- * Convert to WAI
     , toWaiApp
     , toWaiAppPlain
-    , toWaiAppYre
     , warp
     , warpDebug
     , warpEnv
@@ -44,7 +30,6 @@ module Yesod.Core.Dispatch
     , defaultMiddlewaresNoLogging
       -- * WAI subsites
     , WaiSubsite (..)
-    , WaiSubsiteWithAuth (..)
     ) where
 
 import Prelude hiding (exp)
@@ -57,23 +42,19 @@ import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
 
-import Data.Bits ((.|.), finiteBitSize, shiftL)
+import Data.Text (Text, pack)
-import Data.Text (Text)
+import Data.Monoid (mappend)
 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 Network.HTTP.Types (status301)
 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)
 
 import Network.Wai.Middleware.Autohead
 import Network.Wai.Middleware.AcceptOverride
@@ -95,36 +76,12 @@ toWaiAppPlain :: YesodDispatch site => site -> IO W.Application
 toWaiAppPlain site = do
     logger <- makeLogger site
     sb <- makeSessionBackend site
-    getMaxExpires <- getGetMaxExpires
+    return $ toWaiAppYre $ YesodRunnerEnv
-    return $ toWaiAppYre YesodRunnerEnv
             { yreLogger = logger
             , yreSite = site
             , yreSessionBackend = sb
-            , yreGen = defaultGen
-            , 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.
---
--- @since 1.4.29
 toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application
 toWaiAppYre yre req =
     case cleanPath site $ W.pathInfo req of
@@ -135,24 +92,23 @@ toWaiAppYre yre req =
   where
     site = yreSite yre
     sendRedirect :: Yesod master => master -> [Text] -> W.Application
+#if MIN_VERSION_wai(3, 0, 0)
     sendRedirect y segments' env sendResponse =
-         sendResponse $ W.responseLBS status
+         sendResponse $ W.responseLBS status301
+#else
+    sendRedirect y segments' env =
+         return $ W.responseLBS status301
+#endif
                 [ ("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:
-        -- https://github.com/yesodweb/yesod/issues/951
-        status
-            | W.requestMethod env == "GET" = status301
-            | otherwise                    = status307
-
         dest = joinPath y (resolveApproot y env) segments' []
         dest' =
             if S.null (W.rawQueryString env)
                 then dest
-                else dest `mappend`
+                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,13 +130,10 @@ toWaiApp site = do
 toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
 toWaiAppLogger logger site = do
     sb <- makeSessionBackend site
-    getMaxExpires <- getGetMaxExpires
     let yre = YesodRunnerEnv
                 { yreLogger = logger
                 , yreSite = site
                 , yreSessionBackend = sb
-                , yreGen = defaultGen
-                , yreGetMaxExpires = getMaxExpires
                 }
     messageLoggerSource
         site
@@ -197,16 +150,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.
 --
@@ -214,10 +157,19 @@ toWaiAppLogger logger site = do
 warp :: YesodDispatch site => Int -> site -> IO ()
 warp port site = do
     logger <- makeLogger site
-    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings (
+    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings
-        Network.Wai.Handler.Warp.setPort port $
+        Network.Wai.Handler.Warp.defaultSettings
-        Network.Wai.Handler.Warp.setServerName serverValue $
+            { Network.Wai.Handler.Warp.settingsPort = port
-        Network.Wai.Handler.Warp.setOnException (\_ e ->
+            {- FIXME
+            , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
+                [ "Warp/"
+                , Network.Wai.Handler.Warp.warpVersion
+                , " + Yesod/"
+                , showVersion Paths_yesod_core.version
+                , " (core)"
+                ]
+            -}
+            , Network.Wai.Handler.Warp.settingsOnException = const $ \e ->
                 when (shouldLog' e) $
                 messageLoggerSource
                     site
@@ -225,19 +177,15 @@ warp port site = do
                     $(qLocation >>= liftLoc)
                     "yesod-core"
                     LevelError
-                    (toLogStr $ "Exception from Warp: " ++ show e))
+                    (toLogStr $ "Exception from Warp: " ++ show e)
-        Network.Wai.Handler.Warp.defaultSettings)
+            }
   where
-    shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException
+    shouldLog' =
-
+#if MIN_VERSION_warp(2,1,3)
-serverValue :: S8.ByteString
+        Network.Wai.Handler.Warp.defaultShouldDisplayException
-serverValue = S8.pack $ concat
+#else
-    [ "Warp/"
+        const True
-    , Network.Wai.Handler.Warp.warpVersion
+#endif
-    , " + Yesod/"
-    , showVersion Paths_yesod_core.version
-    , " (core)"
-    ]
 
 -- | A default set of middlewares.
 --
@@ -245,7 +193,11 @@ serverValue = S8.pack $ concat
 mkDefaultMiddlewares :: Logger -> IO W.Middleware
 mkDefaultMiddlewares logger = do
     logWare <- mkRequestLogger def
+#if MIN_VERSION_fast_logger(2, 0, 0)
         { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger
+#else
+        { destination = Logger logger
+#endif
         , outputFormat = Apache FromSocket
         }
     return $ logWare . defaultMiddlewaresNoLogging
@@ -272,18 +224,8 @@ warpEnv :: YesodDispatch site => site -> IO ()
 warpEnv site = do
     env <- getEnvironment
     case lookup "PORT" env of
-        Nothing -> error "warpEnv: no PORT environment variable found"
+        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
-
--- | Default constructor for 'yreGetMaxExpires' field. Low level
--- function for simple manual construction of 'YesodRunnerEnv'.
---
--- @since 1.4.29
-getGetMaxExpires :: IO (IO Text)
-getGetMaxExpires = mkAutoUpdate defaultUpdateSettings
-  { updateAction = getCurrentMaxExpiresRFC1123
-  , updateFreq = 24 * 60 * 60 * 1000000 -- Update once per day
-  }

yesod-core/Yesod/Core/Internal.hs

@@ -5,4 +5,3 @@ module Yesod.Core.Internal
     ) where
 
 import Yesod.Core.Internal.Request as X (randomString, parseWaiRequest)
-import Yesod.Core.Internal.TH as X (mkYesodGeneral)

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

@@ -1,10 +1,9 @@
-{-# LANGUAGE TypeFamilies, PatternGuards, CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternGuards #-}
 module Yesod.Core.Internal.LiteApp where
 
-#if !(MIN_VERSION_base(4,11,0))
-import Data.Semigroup (Semigroup(..))
-#endif
 import Yesod.Routes.Class
+import Data.Monoid
 import Yesod.Core.Class.Yesod
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Types
@@ -42,17 +41,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

@@ -1,4 +1,5 @@
-{-# LANGUAGE OverloadedStrings, CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 module Yesod.Core.Internal.Request
     ( parseWaiRequest
     , RequestBodyContents
@@ -22,31 +23,32 @@ import Data.String (IsString)
 import Control.Arrow (second)
 import qualified Network.Wai.Parse as NWP
 import qualified Network.Wai as W
+import System.Random (RandomGen, randomRs)
 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)
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Set as Set
 import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8With, decodeUtf8)
+import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
-import Conduit
+import Data.Conduit
-import Data.Word (Word8, Word64)
+import Data.Conduit.List (sourceList)
+import Data.Conduit.Binary (sourceFile, sinkFile)
+import Data.Word (Word64)
+import Control.Monad.IO.Class (liftIO)
+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 Data.Vector.Storable as V
-import Data.ByteString.Internal (ByteString (PS))
-import qualified Data.Word8 as Word8
 
 -- | Impose a limit on the size of the request body.
 limitRequestBody :: Word64 -> W.Request -> IO W.Request
+#if MIN_VERSION_wai(3, 0, 0)
 limitRequestBody maxLen req = do
     ref <- newIORef maxLen
     return req
@@ -56,29 +58,42 @@ 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
         }
+#else
+limitRequestBody maxLen req =
+    return req { W.requestBody = W.requestBody req $= limit maxLen }
+  where
+    tooLarge = liftIO $ throwIO $ HCWai tooLargeResponse
 
-tooLargeResponse :: Word64 -> Word64 -> W.Response
+    limit 0 = tooLarge
-tooLargeResponse maxLen bodyLen = W.responseLBS
+    limit remaining =
+        await >>= maybe (return ()) go
+      where
+        go bs = do
+            let len = fromIntegral $ S8.length bs
+            if len > remaining
+                then tooLarge
+                else do
+                    yield bs
+                    limit $ remaining - len
+#endif
+
+tooLargeResponse :: W.Response
+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
+parseWaiRequest :: RandomGen g
+                => W.Request
                 -> SessionMap
                 -> Bool
                 -> Maybe Word64 -- ^ max body size
-                -> Either (IO YesodRequest) (IO Int -> IO YesodRequest)
+                -> (Either (IO YesodRequest) (g -> 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
@@ -86,7 +101,7 @@ parseWaiRequest env session useToken mmaxBodySize =
     -- acquisition.
     case etoken of
         Left token -> Left $ mkRequest token
-        Right mkToken -> Right $ mkRequest <=< mkToken
+        Right mkToken -> Right $ mkRequest . mkToken
   where
     mkRequest token' = do
         envLimited <- maybe return limitRequestBody mmaxBodySize env
@@ -129,7 +144,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 $ Just . pack . randomString 10
         | otherwise = Left Nothing
 
 textQueryString :: W.Request -> [(Text, Text)]
@@ -147,7 +162,7 @@ httpAccept = NWP.parseHttpAccept
 
 addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]
 addTwoLetters (toAdd, exist) [] =
-    filter (`Set.notMember` exist) $ toAdd []
+    filter (flip Set.notMember exist) $ toAdd []
 addTwoLetters (toAdd, exist) (l:ls) =
     l : addTwoLetters (toAdd', exist') ls
   where
@@ -158,38 +173,22 @@ 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 :: RandomGen g => Int -> g -> String
-randomString len gen =
+randomString len = take len . map toChar . randomRs (0, 61)
-    liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar
   where
-    asciiChar =
+    toChar i
-      let loop = do
+        | i < 26 = toEnum $ i + fromEnum 'A'
-            x <- gen
+        | i < 52 = toEnum $ i + fromEnum 'a' - 26
-            let y = fromIntegral $ x `mod` 64
+        | otherwise = toEnum $ i + fromEnum '0' - 52
-            case () of
-              ()
-                | 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 =
-    PS fptr offset idx
-  where
-    (fptr, offset, idx) = V.unsafeToForeignPtr v
-{-# INLINE fromByteVector #-}
 
 mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
-mkFileInfoLBS name ct lbs =
+mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs)
-    FileInfo name ct (sourceLazy 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

@@ -0,0 +1,202 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards     #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Yesod.Core.Internal.Response where
+
+import           Blaze.ByteString.Builder     (toByteString)
+import           Data.ByteString              (ByteString)
+import qualified Data.ByteString              as S
+import qualified Data.ByteString.Char8        as S8
+import           Data.CaseInsensitive         (CI)
+import qualified Data.CaseInsensitive         as CI
+import           Network.Wai
+#if MIN_VERSION_wai(2, 0, 0)
+import           Data.Conduit                 (transPipe)
+import           Control.Monad.Trans.Resource (runInternalState, getInternalState, runResourceT, InternalState, closeInternalState)
+import           Control.Monad.Trans.Class    (lift)
+import           Network.Wai.Internal
+import           Control.Exception            (finally)
+#endif
+import           Prelude                      hiding (catch)
+import           Web.Cookie                   (renderSetCookie)
+import           Yesod.Core.Content
+import           Yesod.Core.Types
+import qualified Network.HTTP.Types           as H
+import qualified Data.Text                    as T
+import           Control.Exception            (SomeException, handle)
+import           Blaze.ByteString.Builder     (fromLazyByteString,
+                                               toLazyByteString)
+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           Data.Conduit                 (Flush (..), ($$))
+import qualified Data.Conduit.List            as CL
+
+#if MIN_VERSION_wai(3, 0, 0)
+yarToResponse :: YesodResponse
+              -> (SessionMap -> IO [Header]) -- ^ save session
+              -> YesodRequest
+              -> Request
+              -> InternalState
+              -> (Response -> IO ResponseReceived)
+              -> IO ResponseReceived
+yarToResponse (YRWai a) _ _ _ _ sendResponse = sendResponse a
+yarToResponse (YRWaiApp app) _ _ req _ sendResponse = app req sendResponse
+yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req is sendResponse = do
+    extraHeaders <- do
+        let nsToken = maybe
+                newSess
+                (\n -> Map.insert tokenKey (encodeUtf8 n) newSess)
+                (reqToken yreq)
+        sessionHeaders <- saveSession nsToken
+        return $ ("Content-Type", ct) : map headerToPair sessionHeaders
+    let finalHeaders = extraHeaders ++ map headerToPair hs
+        finalHeaders' len = ("Content-Length", S8.pack $ show len)
+                          : finalHeaders
+
+    let go (ContentBuilder b mlen) = do
+            let hs' = maybe finalHeaders finalHeaders' mlen
+            sendResponse $ ResponseBuilder s hs' b
+        go (ContentFile fp p) = do
+            sendResponse $ ResponseFile s finalHeaders fp p
+        go (ContentSource body) = sendResponse $ responseStream s finalHeaders
+            $ \sendChunk flush -> do
+                transPipe (flip runInternalState is) body
+                $$ CL.mapM_ (\mchunk ->
+                    case mchunk of
+                        Flush -> flush
+                        Chunk builder -> sendChunk builder)
+        go (ContentDontEvaluate c') = go c'
+    go c
+  where
+    s
+        | s' == defaultStatus = H.status200
+        | otherwise = s'
+
+#else
+yarToResponse :: YesodResponse
+              -> (SessionMap -> IO [Header]) -- ^ save session
+              -> YesodRequest
+              -> Request
+#if MIN_VERSION_wai(2, 0, 0)
+              -> InternalState
+#endif
+              -> IO Response
+#if MIN_VERSION_wai(2, 0, 0)
+yarToResponse (YRWaiApp app) _ _ req _ = app req
+yarToResponse (YRWai a) _ _ _ is =
+    case a of
+        ResponseSource s hs w -> return $ ResponseSource s hs $ \f ->
+            w f `finally` closeInternalState is
+        ResponseBuilder{} -> do
+            closeInternalState is
+            return a
+        ResponseFile{} -> do
+            closeInternalState is
+            return a
+#if MIN_VERSION_wai(2, 1, 0)
+        -- Ignore the fallback provided, in case it refers to a ResourceT state
+        -- in a ResponseSource.
+        ResponseRaw raw _ -> return $ ResponseRaw
+            (\f -> raw f `finally` closeInternalState is)
+            (responseLBS H.status500 [("Content-Type", "text/plain")]
+                "yarToResponse: backend does not support raw responses")
+#endif
+#else
+yarToResponse (YRWai a) _ _ _ = return a
+#endif
+yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req
+#if MIN_VERSION_wai(2, 0, 0)
+  is
+#endif
+  = do
+    extraHeaders <- do
+        let nsToken = maybe
+                newSess
+                (\n -> Map.insert tokenKey (encodeUtf8 n) newSess)
+                (reqToken yreq)
+        sessionHeaders <- saveSession nsToken
+        return $ ("Content-Type", ct) : map headerToPair sessionHeaders
+    let finalHeaders = extraHeaders ++ map headerToPair hs
+        finalHeaders' len = ("Content-Length", S8.pack $ show len)
+                          : finalHeaders
+
+#if MIN_VERSION_wai(2, 0, 0)
+    let go (ContentBuilder b mlen) = do
+            let hs' = maybe finalHeaders finalHeaders' mlen
+            closeInternalState is
+            return $ ResponseBuilder s hs' b
+        go (ContentFile fp p) = do
+            closeInternalState is
+            return $ ResponseFile s finalHeaders fp p
+        go (ContentSource body) = return $ ResponseSource s finalHeaders $ \f ->
+            f (transPipe (flip runInternalState is) body) `finally`
+            closeInternalState is
+        go (ContentDontEvaluate c') = go c'
+    go c
+#else
+    let go (ContentBuilder b mlen) =
+            let hs' = maybe finalHeaders finalHeaders' mlen
+             in ResponseBuilder s hs' b
+        go (ContentFile fp p) = ResponseFile s finalHeaders fp p
+        go (ContentSource body) = ResponseSource s finalHeaders body
+        go (ContentDontEvaluate c') = go c'
+    return $ go c
+#endif
+  where
+    s
+        | s' == defaultStatus = H.status200
+        | otherwise = s'
+#endif
+
+-- | Indicates that the user provided no specific status code to be used, and
+-- therefore the default status code should be used. For normal responses, this
+-- would be a 200 response, whereas for error responses this would be an
+-- appropriate status code.
+--
+-- For more information on motivation for this, see:
+--
+-- https://groups.google.com/d/msg/yesodweb/vHDBzyu28TM/bezCvviWp4sJ
+--
+-- Since 1.2.3.1
+defaultStatus :: H.Status
+defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"
+
+-- | Convert Header to a key/value pair.
+headerToPair :: Header
+             -> (CI ByteString, ByteString)
+headerToPair (AddCookie sc) =
+    ("Set-Cookie", toByteString $ renderSetCookie $ sc)
+headerToPair (DeleteCookie key path) =
+    ( "Set-Cookie"
+    , S.concat
+        [ key
+        , "=; path="
+        , path
+        , "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
+        ]
+    )
+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' = maybe (Just $ fromIntegral len) Just mlen
+    len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')
+  where
+    f :: SomeException -> IO (Either ErrorResponse Content)
+    f = return . Left . InternalError . T.pack . show
+evaluateContent c = return (Right c)
+
+getStatus :: ErrorResponse -> H.Status
+getStatus NotFound = H.status404
+getStatus (InternalError _) = H.status500
+getStatus (InvalidArgs _) = H.status400
+getStatus NotAuthenticated = H.status401
+getStatus (PermissionDenied _) = H.status403
+getStatus (BadMethod _) = H.status405

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

@@ -0,0 +1,354 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards     #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE FlexibleContexts  #-}
+module Yesod.Core.Internal.Run where
+
+import Yesod.Core.Internal.Response
+import           Blaze.ByteString.Builder     (toByteString)
+import           Control.Applicative          ((<$>))
+import           Control.Exception            (fromException, bracketOnError, evaluate)
+import qualified Control.Exception            as E
+import           Control.Exception.Lifted     (catch)
+import           Control.Monad                (mplus)
+import           Control.Monad.IO.Class       (MonadIO)
+import           Control.Monad.IO.Class       (liftIO)
+import           Control.Monad.Logger         (LogLevel (LevelError), LogSource,
+                                               liftLoc)
+import           Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, createInternalState, closeInternalState)
+import qualified Data.ByteString              as S
+import qualified Data.ByteString.Char8        as S8
+import qualified Data.IORef                   as I
+import qualified Data.Map                     as Map
+import           Data.Maybe                   (isJust)
+import           Data.Maybe                   (fromMaybe)
+import           Data.Monoid                  (appEndo, mempty)
+import           Data.Text                    (Text)
+import qualified Data.Text                    as T
+import           Data.Text.Encoding           (encodeUtf8)
+import           Data.Text.Encoding           (decodeUtf8With)
+import           Data.Text.Encoding.Error     (lenientDecode)
+import           Language.Haskell.TH.Syntax   (Loc, qLocation)
+import qualified Network.HTTP.Types           as H
+import           Network.Wai
+#if MIN_VERSION_wai(2, 0, 0)
+import           Network.Wai.Internal
+#endif
+import           Prelude                      hiding (catch)
+#if !MIN_VERSION_fast_logger(2, 0, 0)
+import           System.Log.FastLogger        (Logger)
+#endif
+import           System.Log.FastLogger        (LogStr, toLogStr)
+import           System.Random                (newStdGen)
+import           Yesod.Core.Content
+import           Yesod.Core.Class.Yesod
+import           Yesod.Core.Types
+import           Yesod.Core.Internal.Request  (parseWaiRequest,
+                                               tooLargeResponse)
+import           Yesod.Routes.Class           (Route, renderRoute)
+import Control.DeepSeq (($!!), NFData)
+import Control.Monad (liftM)
+
+returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap
+#if MIN_VERSION_bytestring(0, 10, 0)
+returnDeepSessionMap sm = return $!! sm
+#else
+returnDeepSessionMap sm = fmap unWrappedBS `liftM` (return $!! fmap WrappedBS sm)
+
+-- | Work around missing NFData instance for bytestring 0.9.
+newtype WrappedBS = WrappedBS { unWrappedBS :: S8.ByteString }
+instance NFData WrappedBS
+#endif
+
+-- | Function used internally by Yesod in the process of converting a
+-- 'HandlerT' into an 'Application'. Should not be needed by users.
+runHandler :: ToTypedContent c
+           => RunHandlerEnv site
+           -> HandlerT site IO c
+           -> YesodApp
+runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
+    let toErrorHandler e =
+            case fromException e of
+                Just (HCError x) -> x
+                _ -> InternalError $ T.pack $ show e
+    istate <- liftIO $ I.newIORef GHState
+        { ghsSession = reqSession yreq
+        , ghsRBC = Nothing
+        , ghsIdent = 1
+        , ghsCache = mempty
+        , ghsHeaders = mempty
+        }
+    let hd = HandlerData
+            { handlerRequest = yreq
+            , handlerEnv     = rhe
+            , handlerState   = istate
+            , handlerToParent = const ()
+            , handlerResource = resState
+            }
+    contents' <- catch (fmap Right $ unHandlerT handler hd)
+        (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
+                      $ fromException e)
+    state <- liftIO $ I.readIORef istate
+
+    (finalSession, mcontents1) <- (do
+        finalSession <- returnDeepSessionMap (ghsSession state)
+        return (finalSession, Nothing)) `E.catch` \e -> return
+            (Map.empty, Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
+
+    (headers, mcontents2) <- (do
+        headers <- return $!! appEndo (ghsHeaders state) []
+        return (headers, Nothing)) `E.catch` \e -> return
+            ([], Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
+
+    let contents =
+            case mcontents1 `mplus` mcontents2 of
+                Just x -> x
+                Nothing -> either id (HCContent defaultStatus . toTypedContent) contents'
+    let handleError e = flip runInternalState resState $ do
+            yar <- rheOnError e yreq
+                { reqSession = finalSession
+                }
+            case yar of
+                YRPlain status' hs ct c sess ->
+                    let hs' = headers ++ hs
+                        status
+                            | status' == defaultStatus = getStatus e
+                            | otherwise = status'
+                     in return $ YRPlain status hs' ct c sess
+                YRWai _ -> return yar
+    let sendFile' ct fp p =
+            return $ YRPlain H.status200 headers ct (ContentFile fp p) finalSession
+    contents1 <- evaluate contents `E.catch` \e -> return
+        (HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
+    case contents1 of
+        HCContent status (TypedContent ct c) -> do
+            ec' <- liftIO $ evaluateContent c
+            case ec' of
+                Left e -> handleError e
+                Right c' -> return $ YRPlain status headers ct c' finalSession
+        HCError e -> handleError e
+        HCRedirect status loc -> do
+            let disable_caching x =
+                      Header "Cache-Control" "no-cache, must-revalidate"
+                    : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
+                    : x
+                hs = (if status /= H.movedPermanently301 then disable_caching else id)
+                      $ Header "Location" (encodeUtf8 loc) : headers
+            return $ YRPlain
+                status hs typePlain emptyContent
+                finalSession
+        HCSendFile ct fp p -> catch
+            (sendFile' ct fp p)
+            (handleError . toErrorHandler)
+        HCCreated loc -> do
+            let hs = Header "Location" (encodeUtf8 loc) : headers
+            return $ YRPlain
+                H.status201
+                hs
+                typePlain
+                emptyContent
+                finalSession
+        HCWai r -> return $ YRWai r
+        HCWaiApp a -> return $ YRWaiApp a
+
+safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
+       -> ErrorResponse
+       -> YesodApp
+safeEh log' er req = do
+    liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError
+           $ toLogStr $ "Error handler errored out: " ++ show er
+    return $ YRPlain
+        H.status500
+        []
+        typePlain
+        (toContent ("Internal Server Error" :: S.ByteString))
+        (reqSession req)
+
+-- | 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 '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
+-- @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
+-- @HandlerT@ is completely ignored, including changes to the
+-- session, cookies or headers.  We only return you the
+-- @HandlerT@'s return value.
+runFakeHandler :: (Yesod site, MonadIO m) =>
+                  SessionMap
+               -> (site -> Logger)
+               -> site
+               -> HandlerT site IO a
+               -> m (Either ErrorResponse a)
+runFakeHandler fakeSessionMap logger site handler = liftIO $ do
+  ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
+  let handler' = do liftIO . I.writeIORef ret . Right =<< handler
+                    return ()
+  let yapp = runHandler
+         RunHandlerEnv
+            { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
+            , rheRoute = Nothing
+            , rheSite = site
+            , rheUpload = fileUpload site
+            , rheLog = messageLoggerSource site $ logger site
+            , rheOnError = errHandler
+            }
+        handler'
+      errHandler err req = do
+          liftIO $ I.writeIORef ret (Left err)
+          return $ YRPlain
+                     H.status500
+                     []
+                     typePlain
+                     (toContent ("runFakeHandler: errHandler" :: S8.ByteString))
+                     (reqSession req)
+      fakeWaiRequest = Request
+          { requestMethod  = "POST"
+          , httpVersion    = H.http11
+          , rawPathInfo    = "/runFakeHandler/pathInfo"
+          , rawQueryString = ""
+#if MIN_VERSION_wai(2, 0, 0)
+          , requestHeaderHost = Nothing
+#else
+          , serverName     = "runFakeHandler-serverName"
+          , serverPort     = 80
+#endif
+          , requestHeaders = []
+          , isSecure       = False
+          , remoteHost     = error "runFakeHandler-remoteHost"
+          , pathInfo       = ["runFakeHandler", "pathInfo"]
+          , queryString    = []
+#if MIN_VERSION_wai(3, 0, 0)
+          , requestBody    = return mempty
+#else
+          , requestBody    = mempty
+#endif
+          , vault          = mempty
+          , requestBodyLength = KnownLength 0
+          }
+      fakeRequest =
+        YesodRequest
+          { reqGetParams  = []
+          , reqCookies    = []
+          , reqWaiRequest = fakeWaiRequest
+          , reqLangs      = []
+          , reqToken      = Just "NaN" -- not a nonce =)
+          , reqAccept     = []
+          , reqSession    = fakeSessionMap
+          }
+  _ <- runResourceT $ yapp fakeRequest
+  I.readIORef ret
+{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
+
+yesodRunner :: (ToTypedContent res, Yesod site)
+            => HandlerT site IO res
+            -> YesodRunnerEnv site
+            -> Maybe (Route site)
+            -> Application
+#if MIN_VERSION_wai(3, 0, 0)
+yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
+  | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse tooLargeResponse
+#else
+yesodRunner handler' YesodRunnerEnv {..} route req
+  | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse
+#endif
+  | otherwise = do
+    let dontSaveSession _ = return []
+    (session, saveSession) <- liftIO $ do
+        maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend
+    let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
+    yreq <-
+        case mkYesodReq of
+            Left yreq -> return yreq
+            Right needGen -> liftIO $ needGen <$> newStdGen
+    let ra = resolveApproot yreSite req
+    let log' = messageLoggerSource yreSite yreLogger
+        -- We set up two environments: the first one has a "safe" error handler
+        -- which will never throw an exception. The second one uses the
+        -- user-provided errorHandler function. If that errorHandler function
+        -- errors out, it will use the safeEh below to recover.
+        rheSafe = RunHandlerEnv
+            { rheRender = yesodRender yreSite ra
+            , rheRoute = route
+            , rheSite = yreSite
+            , rheUpload = fileUpload yreSite
+            , rheLog = log'
+            , rheOnError = safeEh log'
+            }
+        rhe = rheSafe
+            { rheOnError = runHandler rheSafe . errorHandler
+            }
+#if MIN_VERSION_wai(3, 0, 0)
+
+    E.bracket createInternalState closeInternalState $ \is -> do
+        yreq' <- yreq
+        yar <- runInternalState (runHandler rhe handler yreq') is
+        yarToResponse yar saveSession yreq' req is sendResponse
+
+#else
+
+#if MIN_VERSION_wai(2, 0, 0)
+    bracketOnError createInternalState closeInternalState $ \is -> do
+        yreq' <- yreq
+        yar <- runInternalState (runHandler rhe handler yreq') is
+        liftIO $ yarToResponse yar saveSession yreq' req is
+#else
+    yar <- runHandler rhe handler yreq
+    liftIO $ yarToResponse yar saveSession yreq req
+#endif
+#endif
+  where
+    mmaxLen = maximumContentLength yreSite route
+    handler = yesodMiddleware handler'
+
+yesodRender :: Yesod y
+            => y
+            -> ResolvedApproot
+            -> Route y
+            -> [(Text, Text)] -- ^ url query string
+            -> Text
+yesodRender y ar url params =
+    decodeUtf8With lenientDecode $ toByteString $
+    fromMaybe
+        (joinPath y ar ps
+          $ params ++ params')
+        (urlRenderOverride y url)
+  where
+    (ps, params') = renderRoute url
+
+resolveApproot :: Yesod master => master -> Request -> ResolvedApproot
+resolveApproot master req =
+    case approot of
+        ApprootRelative -> ""
+        ApprootStatic t -> t
+        ApprootMaster f -> f master
+        ApprootRequest f -> f master req
+
+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
+        }

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

@@ -11,10 +11,11 @@ import qualified Web.ClientSession as CS
 import Data.Serialize
 import Data.Time
 import Data.ByteString (ByteString)
-import Control.Monad (guard)
+import Control.Concurrent (forkIO, killThread, threadDelay)
+import Control.Monad (forever, guard)
 import Yesod.Core.Types
 import Yesod.Core.Internal.Util
-import Control.AutoUpdate
+import qualified Data.IORef as I
 
 encodeClientSession :: CS.Key
                     -> CS.IV
@@ -43,28 +44,25 @@ decodeClientSession key date rhost encrypted = do
 ----------------------------------------------------------------------
 
 
--- Originally copied from Kazu's date-cache, but now using mkAutoUpdate.
+-- Mostly copied from Kazu's date-cache, but with modifications
+-- that better suit our needs.
 --
 -- The cached date is updated every 10s, we don't need second
 -- resolution for session expiration times.
---
--- The second component of the returned tuple used to be an action that
--- killed the updater thread, but is now a no-op that's just there
--- to preserve the type.
 
 clientSessionDateCacher ::
-     NominalDiffTime -- ^ Inactive session validity.
+     NominalDiffTime -- ^ Inactive session valitity.
   -> IO (IO ClientSessionDateCache, IO ())
 clientSessionDateCacher validity = do
-    getClientSessionDateCache <- mkAutoUpdate defaultUpdateSettings
+    ref <- getUpdated >>= I.newIORef
-      { updateAction = getUpdated
+    tid <- forkIO $ forever (doUpdate ref)
-      , updateFreq   = 10000000 -- 10s
+    return $! (I.readIORef ref, killThread tid)
-      }
-
-    return (getClientSessionDateCache, return ())
   where
     getUpdated = do
       now <- getCurrentTime
       let expires  = validity `addUTCTime` now
           expiresS = runPut (putTime expires)
       return $! ClientSessionDateCache now expires expiresS
+    doUpdate ref = do
+      threadDelay 10000000 -- 10s
+      I.writeIORef ref =<< getUpdated

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

@@ -0,0 +1,136 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Yesod.Core.Internal.TH where
+
+import Prelude hiding (exp)
+import Yesod.Core.Handler
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+import qualified Network.Wai as W
+
+import Data.ByteString.Lazy.Char8 ()
+import Data.List (foldl')
+
+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
+
+-- | 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 res = mkYesodDataGeneral name False res
+
+mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
+mkYesodSubData name res = mkYesodDataGeneral name True res
+
+mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
+mkYesodDataGeneral name isSub res = do
+    let (name':rest) = words name
+    fmap fst $ mkYesodGeneral name' rest isSub res
+
+-- | See 'mkYesodData'.
+mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
+mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False
+
+-- | Get the Handler and Widget type synonyms for the given site.
+masterTypeSyns :: Type -> [Dec]
+masterTypeSyns site =
+    [ TySynD (mkName "Handler") []
+      $ ConT ''HandlerT `AppT` site `AppT` ConT ''IO
+    , TySynD (mkName "Widget")  []
+      $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
+    ]
+
+mkYesodGeneral :: String                   -- ^ foundation type
+               -> [String]                 -- ^ arguments for the type
+               -> Bool                     -- ^ it this a subsite
+               -> [ResourceTree String]
+               -> Q([Dec],[Dec])
+mkYesodGeneral name args isSub resS = do
+    renderRouteDec <- mkRenderRouteInstance site res
+    routeAttrsDec  <- mkRouteAttrsInstance site res
+    dispatchDec    <- mkDispatchInstance site res
+    parse <- mkParseRouteInstance site res
+    let rname = mkName $ "resources" ++ name
+    eres <- lift resS
+    let resourcesDec =
+            [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
+            , FunD rname [Clause [] (NormalB eres) []]
+            ]
+    let dataDec = concat
+            [ [parse]
+            , renderRouteDec
+            , [routeAttrsDec]
+            , resourcesDec
+            , if isSub then [] else masterTypeSyns site
+            ]
+    return (dataDec, dispatchDec)
+  where site    = foldl' AppT (ConT $ mkName name) (map (VarT . mkName) args)
+        res     = map (fmap parseType) resS
+
+mkMDS :: Q Exp -> MkDispatchSettings
+mkMDS 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 = [|notFound >> return ()|]
+    , mds405 = [|badMethod >> return ()|]
+    , mdsGetHandler = defaultGetHandler
+    }
+
+-- | 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
+                   -> [ResourceTree a]    -- ^ The resource
+                   -> DecsQ
+mkDispatchInstance master res = do
+    clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res
+    let thisDispatch = FunD 'yesodDispatch [clause']
+    return [InstanceD [] yDispatch [thisDispatch]]
+  where
+    yDispatch = ConT ''YesodDispatch `AppT` master
+
+mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
+mkYesodSubDispatch res = do
+    clause' <- mkDispatchClause (mkMDS [|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)

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

@@ -1,19 +1,17 @@
-{-# LANGUAGE CPP #-}
 module Yesod.Core.Internal.Util
     ( putTime
     , getTime
     , formatW3
     , formatRFC1123
     , formatRFC822
-    , getCurrentMaxExpiresRFC1123
     ) where
 
 import           Data.Int       (Int64)
 import           Data.Serialize (Get, Put, Serialize (..))
 import qualified Data.Text      as T
 import           Data.Time      (Day (ModifiedJulianDay, toModifiedJulianDay),
-                                 DiffTime, UTCTime (..), formatTime,
+                                 DiffTime, UTCTime (..), formatTime)
-                                 getCurrentTime, addUTCTime, defaultTimeLocale)
+import           System.Locale  (defaultTimeLocale)
 
 putTime :: UTCTime -> Put
 putTime (UTCTime d t) =
@@ -46,9 +44,3 @@ formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"
 -- | Format as per RFC 822.
 formatRFC822 :: UTCTime -> T.Text
 formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
-
-{- | Get the time 365 days from now in RFC 1123 format. For use as an expiry
-date on a resource that never expires. See RFC 2616 section 14.21 for details.
--}
-getCurrentMaxExpiresRFC1123 :: IO T.Text
-getCurrentMaxExpiresRFC1123 = fmap (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime

yesod-core/Yesod/Core/Json.hs

@@ -0,0 +1,148 @@
+{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Yesod.Core.Json
+    ( -- * Convert from a JSON value
+      defaultLayoutJson
+    , jsonToRepJson
+    , returnJson
+    , provideJson
+
+      -- * Convert to a JSON value
+    , parseJsonBody
+    , parseJsonBody_
+    , requireJsonBody
+
+      -- * Produce JSON values
+    , J.Value (..)
+    , J.ToJSON (..)
+    , J.FromJSON (..)
+    , array
+    , object
+    , (.=)
+    , (J..:)
+
+      -- * Convenience functions
+    , jsonOrRedirect
+    , acceptsJson
+    ) where
+
+import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep)
+import Control.Monad.Trans.Writer (Writer)
+import Control.Monad.Trans.Resource (runExceptionT)
+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 (WidgetT)
+import Yesod.Routes.Class
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Parser as JP
+import Data.Aeson ((.=), object)
+import Data.Conduit.Attoparsec (sinkParser)
+import Data.Text (pack)
+import qualified Data.Vector as V
+import Data.Conduit
+import Data.Conduit.Lift
+import qualified Data.ByteString.Char8 as B8
+import Data.Maybe (listToMaybe)
+import Control.Monad (liftM)
+
+-- | Provide both an HTML and JSON representation for a piece of
+-- data, using the default layout for the HTML output
+-- ('defaultLayout').
+--
+-- /Since: 0.3.0/
+defaultLayoutJson :: (Yesod site, J.ToJSON a)
+                  => WidgetT site IO ()  -- ^ HTML
+                  -> HandlerT site IO a  -- ^ JSON
+                  -> HandlerT site IO TypedContent
+defaultLayoutJson w json = selectRep $ do
+    provideRep $ defaultLayout w
+    provideRep $ fmap J.toJSON json
+
+-- | Wraps a data type in a 'RepJson'.  The data type must
+-- support conversion to JSON via 'J.ToJSON'.
+--
+-- /Since: 0.3.0/
+jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value
+jsonToRepJson = return . J.toJSON
+{-# DEPRECATED jsonToRepJson "Use returnJson instead" #-}
+
+-- | Convert a value to a JSON representation via aeson\'s 'J.toJSON' function.
+--
+-- Since 1.2.1
+returnJson :: (Monad m, J.ToJSON a) => a -> m J.Value
+returnJson = return . J.toJSON
+
+-- | Provide a JSON representation for usage with 'selectReps', using aeson\'s
+-- 'J.toJSON' function to perform the conversion.
+--
+-- Since 1.2.1
+provideJson :: (Monad m, J.ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()
+provideJson = provideRep . return . J.toJSON
+
+-- | 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'@.
+--
+-- 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
+#if MIN_VERSION_resourcet(1,1,0)
+    eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value')
+#else
+    eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'
+#endif
+    return $ case eValue of
+        Left e -> J.Error $ show e
+        Right value -> J.fromJSON value
+
+-- | Same as 'parseJsonBody', but return an invalid args response on a parse
+-- error.
+parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
+parseJsonBody_ = requireJsonBody
+{-# DEPRECATED parseJsonBody_ "Use requireJsonBody instead" #-}
+
+-- | Same as 'parseJsonBody', but return an invalid args response on a parse
+-- error.
+requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a
+requireJsonBody = do
+    ra <- parseJsonBody
+    case ra of
+        J.Error s -> invalidArgs [pack s]
+        J.Success a -> return a
+
+-- | Convert a list of values to an 'J.Array'.
+array :: J.ToJSON a => [a] -> J.Value
+array = J.Array . V.fromList . map J.toJSON
+
+-- | jsonOrRedirect simplifies the scenario where a POST handler sends a different
+-- response based on Accept headers:
+--
+--     1. 200 with JSON data if the client prefers
+--     @application\/json@ (e.g. AJAX, see 'acceptsJSON').
+--
+--     2. 3xx otherwise, following the PRG pattern.
+jsonOrRedirect :: (MonadHandler m, J.ToJSON a)
+               => Route (HandlerSite m) -- ^ Redirect target
+               -> a            -- ^ Data to send via JSON
+               -> m J.Value
+jsonOrRedirect r j = do
+    q <- acceptsJson
+    if q then return (J.toJSON j)
+         else redirect r
+
+-- | Returns @True@ if the client prefers @application\/json@ as
+-- indicated by the @Accept@ HTTP header.
+acceptsJson :: MonadHandler m => m Bool
+acceptsJson =  (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
+            .  listToMaybe
+            .  reqAccept)
+           `liftM` getRequest

yesod-core/Yesod/Core/Types.hs

@@ -0,0 +1,539 @@
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE CPP #-}
+module Yesod.Core.Types where
+
+import qualified Blaze.ByteString.Builder           as BBuilder
+import qualified Blaze.ByteString.Builder.Char.Utf8
+import           Control.Applicative                (Applicative (..))
+import           Control.Applicative                ((<$>))
+import           Control.Arrow                      (first)
+import           Control.Exception                  (Exception)
+import           Control.Monad                      (liftM, ap)
+import           Control.Monad.Base                 (MonadBase (liftBase))
+import           Control.Monad.Catch                (MonadCatch (..))
+#if MIN_VERSION_exceptions(0,6,0)
+import           Control.Monad.Catch                (MonadMask (..))
+#endif
+import           Control.Monad.IO.Class             (MonadIO (liftIO))
+import           Control.Monad.Logger               (LogLevel, LogSource,
+                                                     MonadLogger (..))
+import           Control.Monad.Trans.Control        (MonadBaseControl (..))
+import           Control.Monad.Trans.Resource       (MonadResource (..), InternalState, runInternalState, MonadThrow (..), monadThrow, ResourceT)
+#if !MIN_VERSION_resourcet(1,1,0)
+import           Control.Monad.Trans.Resource       (MonadUnsafeIO (..))
+#endif
+import           Data.ByteString                    (ByteString)
+import qualified Data.ByteString.Lazy               as L
+import           Data.Conduit                       (Flush, Source)
+import           Data.Dynamic                       (Dynamic)
+import           Data.IORef                         (IORef)
+import           Data.Map                           (Map, unionWith)
+import qualified Data.Map                           as Map
+import           Data.Monoid                        (Endo (..), Last (..),
+                                                     Monoid (..))
+import           Data.Serialize                     (Serialize (..),
+                                                     putByteString)
+import           Data.String                        (IsString (fromString))
+import           Data.Text                          (Text)
+import qualified Data.Text                          as T
+import qualified Data.Text.Lazy.Builder             as TBuilder
+import           Data.Time                          (UTCTime)
+import           Data.Typeable                      (Typeable)
+import           Data.Typeable                      (TypeRep)
+import           Language.Haskell.TH.Syntax         (Loc)
+import qualified Network.HTTP.Types                 as H
+import           Network.Wai                        (FilePart,
+                                                     RequestBodyLength)
+import qualified Network.Wai                        as W
+import qualified Network.Wai.Parse                  as NWP
+#if MIN_VERSION_fast_logger(2, 0, 0)
+import           System.Log.FastLogger              (LogStr, LoggerSet, toLogStr, pushLogStr)
+import           Network.Wai.Logger                 (DateCacheGetter)
+#else
+import           System.Log.FastLogger              (LogStr, Logger, toLogStr)
+#endif
+import           Text.Blaze.Html                    (Html)
+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 Prelude hiding (catch)
+import Control.DeepSeq (NFData (rnf))
+
+-- Sessions
+type SessionMap = Map Text ByteString
+
+type SaveSession = SessionMap -- ^ The session contents after running the handler
+                -> IO [Header]
+
+newtype SessionBackend = SessionBackend
+    { sbLoadSession :: W.Request
+                    -> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session
+    }
+
+data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString SessionMap
+    deriving (Show, Read)
+instance Serialize SessionCookie where
+    put (SessionCookie a b c) = do
+        either putTime putByteString a
+        put b
+        put (map (first T.unpack) $ Map.toList c)
+
+    get = do
+        a <- getTime
+        b <- get
+        c <- map (first T.pack) <$> get
+        return $ SessionCookie (Left a) b (Map.fromList c)
+
+data ClientSessionDateCache =
+  ClientSessionDateCache {
+    csdcNow               :: !UTCTime
+  , csdcExpires           :: !UTCTime
+  , csdcExpiresSerialized :: !ByteString
+  } deriving (Eq, Show)
+
+-- | The parsed request information. This type augments the standard WAI
+-- 'W.Request' with additional information.
+data YesodRequest = YesodRequest
+    { reqGetParams  :: ![(Text, Text)]
+      -- ^ Same as 'W.queryString', but decoded to @Text@.
+    , reqCookies    :: ![(Text, Text)]
+    , reqWaiRequest :: !W.Request
+    , reqLangs      :: ![Text]
+      -- ^ Languages which the client supports. This is an ordered list by preference.
+    , reqToken      :: !(Maybe Text)
+      -- ^ A random, session-specific token used to prevent CSRF attacks.
+    , reqSession    :: !SessionMap
+      -- ^ Initial session sent from the client.
+      --
+      -- Since 1.2.0
+    , reqAccept     :: ![ContentType]
+      -- ^ An ordered list of the accepted content types.
+      --
+      -- Since 1.2.0
+    }
+
+-- | An augmented WAI 'W.Response'. This can either be a standard @Response@,
+-- or a higher-level data structure which Yesod will turn into a @Response@.
+data YesodResponse
+    = YRWai !W.Response
+    | YRWaiApp !W.Application
+    | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap
+
+-- | A tuple containing both the POST parameters and submitted files.
+type RequestBodyContents =
+    ( [(Text, Text)]
+    , [(Text, FileInfo)]
+    )
+
+data FileInfo = FileInfo
+    { fileName        :: !Text
+    , fileContentType :: !Text
+    , fileSourceRaw   :: !(Source (ResourceT IO) ByteString)
+    , fileMove        :: !(FilePath -> IO ())
+    }
+
+data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
+#if MIN_VERSION_wai_extra(2, 0, 1)
+                | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)
+#else
+                | FileUploadDisk !(NWP.BackEnd FilePath)
+#endif
+                | FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))
+
+-- | How to determine the root of the application for constructing URLs.
+--
+-- Note that future versions of Yesod may add new constructors without bumping
+-- the major version number. As a result, you should /not/ pattern match on
+-- @Approot@ values.
+data Approot master = ApprootRelative -- ^ No application root.
+                    | ApprootStatic !Text
+                    | ApprootMaster !(master -> Text)
+                    | ApprootRequest !(master -> W.Request -> Text)
+
+type ResolvedApproot = Text
+
+data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
+    deriving (Eq, Show, Read)
+
+data ScriptLoadPosition master
+    = BottomOfBody
+    | BottomOfHeadBlocking
+    | BottomOfHeadAsync (BottomOfHeadAsync master)
+
+type BottomOfHeadAsync master
+       = [Text] -- ^ urls to load asynchronously
+      -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion
+      -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>
+
+newtype Cache = Cache (Map TypeRep Dynamic)
+    deriving Monoid
+
+type Texts = [Text]
+
+-- | Wrap up a normal WAI application as a Yesod subsite.
+newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
+
+data RunHandlerEnv site = RunHandlerEnv
+    { rheRender   :: !(Route site -> [(Text, Text)] -> Text)
+    , rheRoute    :: !(Maybe (Route site))
+    , rheSite     :: !site
+    , rheUpload   :: !(RequestBodyLength -> FileUpload)
+    , rheLog      :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
+    , rheOnError  :: !(ErrorResponse -> YesodApp)
+      -- ^ How to respond when an error is thrown internally.
+      --
+      -- Since 1.2.0
+    }
+
+data HandlerData site parentRoute = HandlerData
+    { handlerRequest  :: !YesodRequest
+    , handlerEnv      :: !(RunHandlerEnv site)
+    , handlerState    :: !(IORef GHState)
+    , handlerToParent :: !(Route site -> parentRoute)
+    , handlerResource :: !InternalState
+    }
+
+data YesodRunnerEnv site = YesodRunnerEnv
+    { yreLogger         :: !Logger
+    , yreSite           :: !site
+    , yreSessionBackend :: !(Maybe SessionBackend)
+    }
+
+data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv
+    { 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 m
+    = 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 HandlerT site m a = HandlerT
+    { unHandlerT :: HandlerData site (MonadRoute m) -> m a
+    }
+
+type family MonadRoute (m :: * -> *)
+type instance MonadRoute IO = ()
+type instance MonadRoute (HandlerT site m) = (Route site)
+
+data GHState = GHState
+    { ghsSession :: SessionMap
+    , ghsRBC     :: Maybe RequestBodyContents
+    , ghsIdent   :: Int
+    , ghsCache   :: Cache
+    , 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 '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 WidgetT site m a = WidgetT
+    { unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site))
+    }
+
+instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
+    mempty = return ()
+    mappend x y = x >> y
+
+type RY master = Route master -> [(Text, Text)] -> Text
+
+-- | Newtype wrapper allowing injection of arbitrary content into CSS.
+--
+-- Usage:
+--
+-- > toWidget $ CssBuilder "p { color: red }"
+--
+-- Since: 1.1.3
+newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
+
+-- | Content for a web page. By providing this datatype, we can easily create
+-- generic site templates, which would have the type signature:
+--
+-- > PageContent url -> HtmlUrl url
+data PageContent url = PageContent
+    { pageTitle :: Html
+    , pageHead  :: HtmlUrl url
+    , pageBody  :: HtmlUrl url
+    }
+
+data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length.
+             | ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder))
+             | ContentFile !FilePath !(Maybe FilePart)
+             | ContentDontEvaluate !Content
+
+data TypedContent = TypedContent !ContentType !Content
+
+type RepHtml = Html
+{-# DEPRECATED RepHtml "Please use Html instead" #-}
+newtype RepJson = RepJson Content
+newtype RepPlain = RepPlain Content
+newtype RepXml = RepXml Content
+
+type ContentType = ByteString -- FIXME Text?
+
+-- | Prevents a response body from being fully evaluated before sending the
+-- request.
+--
+-- Since 1.1.0
+newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
+
+-- | Responses to indicate some form of an error occurred. These are different
+-- from 'SpecialResponse' in that they allow for custom error pages.
+data ErrorResponse =
+      NotFound
+    | InternalError Text
+    | InvalidArgs [Text]
+    | NotAuthenticated
+    | PermissionDenied Text
+    | BadMethod H.Method
+    deriving (Show, Eq, Typeable)
+
+----- header stuff
+-- | Headers to be added to a 'Result'.
+data Header =
+    AddCookie SetCookie
+    | DeleteCookie ByteString ByteString
+    | Header ByteString ByteString
+    deriving (Eq, Show)
+
+-- FIXME In the next major version bump, let's just add strictness annotations
+-- to Header (and probably everywhere else). We can also add strictness
+-- annotations to SetCookie in the cookie package.
+instance NFData Header where
+    rnf (AddCookie x) = rnf x
+    rnf (DeleteCookie x y) = x `seq` y `seq` ()
+    rnf (Header x y) = x `seq` y `seq` ()
+
+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)] }
+    deriving (Show, Eq)
+data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }
+    deriving (Show, Eq)
+newtype Title = Title { unTitle :: Html }
+
+newtype Head url = Head (HtmlUrl url)
+    deriving Monoid
+newtype Body url = Body (HtmlUrl url)
+    deriving Monoid
+
+type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder
+
+data GWData a = GWData
+    { gwdBody        :: !(Body a)
+    , gwdTitle       :: !(Last Title)
+    , gwdScripts     :: !(UniqueList (Script a))
+    , gwdStylesheets :: !(UniqueList (Stylesheet a))
+    , gwdCss         :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type
+    , gwdJavascript  :: !(Maybe (JavascriptUrl a))
+    , gwdHead        :: !(Head a)
+    }
+instance Monoid (GWData a) where
+    mempty = GWData mempty mempty mempty mempty mempty mempty mempty
+    mappend (GWData a1 a2 a3 a4 a5 a6 a7)
+            (GWData b1 b2 b3 b4 b5 b6 b7) = GWData
+        (a1 `mappend` b1)
+        (a2 `mappend` b2)
+        (a3 `mappend` b3)
+        (a4 `mappend` b4)
+        (unionWith mappend a5 b5)
+        (a6 `mappend` b6)
+        (a7 `mappend` b7)
+
+data HandlerContents =
+      HCContent H.Status !TypedContent
+    | HCError ErrorResponse
+    | HCSendFile ContentType FilePath (Maybe FilePart)
+    | HCRedirect H.Status Text
+    | HCCreated Text
+    | HCWai W.Response
+    | HCWaiApp W.Application
+    deriving Typeable
+
+instance Show HandlerContents where
+    show (HCContent status (TypedContent t _)) = "HCContent " ++ show (status, t)
+    show (HCError e) = "HCError " ++ show e
+    show (HCSendFile ct fp mfp) = "HCSendFile " ++ show (ct, fp, mfp)
+    show (HCRedirect s t) = "HCRedirect " ++ show (s, t)
+    show (HCCreated t) = "HCCreated " ++ show t
+    show (HCWai _) = "HCWai"
+    show (HCWaiApp _) = "HCWaiApp"
+instance Exception HandlerContents
+
+-- Instances for WidgetT
+instance Monad m => Functor (WidgetT site m) where
+    fmap = liftM
+instance Monad m => Applicative (WidgetT site m) where
+    pure = return
+    (<*>) = ap
+instance Monad m => Monad (WidgetT site m) where
+    return a = WidgetT $ const $ return (a, mempty)
+    WidgetT x >>= f = WidgetT $ \r -> do
+        (a, wa) <- x r
+        (b, wb) <- unWidgetT (f a) r
+        return (b, wa `mappend` wb)
+instance MonadIO m => MonadIO (WidgetT site m) where
+    liftIO = lift . liftIO
+instance MonadBase b m => MonadBase b (WidgetT site m) where
+    liftBase = WidgetT . const . liftBase . fmap (, mempty)
+instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
+    data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
+    liftBaseWith f = WidgetT $ \reader' ->
+        liftBaseWith $ \runInBase ->
+            liftM (\x -> (x, mempty))
+            (f $ liftM StW . runInBase . flip unWidgetT reader')
+    restoreM (StW base) = WidgetT $ const $ restoreM base
+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 MonadTrans (WidgetT site) where
+    lift = WidgetT . const . liftM (, mempty)
+instance MonadThrow m => MonadThrow (WidgetT site m) where
+#if MIN_VERSION_resourcet(1,1,0)
+    throwM = lift . throwM
+
+instance MonadCatch m => MonadCatch (HandlerT site m) where
+  catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r
+#if MIN_VERSION_exceptions(0,6,0)
+instance MonadMask m => MonadMask (HandlerT site m) where
+#endif
+  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
+#if MIN_VERSION_exceptions(0,6,0)
+instance MonadMask m => MonadMask (WidgetT site m) where
+#endif
+  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)
+#else
+    monadThrow = lift . monadThrow
+#endif
+
+#if MIN_VERSION_resourcet(1,1,0)
+instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
+#else
+instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where
+#endif
+    liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)
+
+instance MonadIO m => MonadLogger (WidgetT site m) where
+    monadLoggerLog a b c d = WidgetT $ \hd ->
+        liftIO $ fmap (, mempty) $ rheLog (handlerEnv hd) a b c (toLogStr d)
+
+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 m => Monad (HandlerT site m) where
+    return = HandlerT . const . return
+    HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r
+instance MonadIO m => MonadIO (HandlerT site m) where
+    liftIO = lift . liftIO
+instance MonadBase b m => MonadBase b (HandlerT site m) where
+    liftBase = lift . liftBase
+instance Monad m => MonadReader site (HandlerT site m) where
+    ask = HandlerT $ return . rheSite . handlerEnv
+    local f (HandlerT g) = HandlerT $ \hd -> g hd
+        { handlerEnv = (handlerEnv hd)
+            { 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
+    data StM (HandlerT site m) a = StH (StM m a)
+    liftBaseWith f = HandlerT $ \reader' ->
+        liftBaseWith $ \runInBase ->
+            f $ liftM StH . runInBase . (\(HandlerT r) -> r reader')
+    restoreM (StH base) = HandlerT $ const $ restoreM base
+
+instance MonadThrow m => MonadThrow (HandlerT site m) where
+#if MIN_VERSION_resourcet(1,1,0)
+    throwM = lift . monadThrow
+#else
+    monadThrow = lift . monadThrow
+#endif
+
+#if MIN_VERSION_resourcet(1,1,0)
+instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where
+#else
+instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where
+#endif
+    liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
+
+instance MonadIO m => MonadLogger (HandlerT site m) where
+    monadLoggerLog a b c d = HandlerT $ \hd ->
+        liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
+
+instance Monoid (UniqueList x) where
+    mempty = UniqueList id
+    UniqueList x `mappend` UniqueList y = UniqueList $ x . y
+
+instance IsString Content where
+    fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString
+
+instance RenderRoute WaiSubsite where
+    data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]
+        deriving (Show, Eq, Read, Ord)
+    renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
+instance ParseRoute WaiSubsite where
+    parseRoute (x, y) = Just $ WaiSubsiteRoute x y
+
+#if MIN_VERSION_fast_logger(2, 0, 0)
+data Logger = Logger
+    { loggerSet :: !LoggerSet
+    , loggerDate :: !DateCacheGetter
+    }
+
+loggerPutStr :: Logger -> LogStr -> IO ()
+loggerPutStr (Logger ls _) = pushLogStr ls
+#endif

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,10 @@ import Text.Cassius
 import Text.Julius
 import Yesod.Routes.Class
 import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
+import Control.Monad.IO.Class (MonadIO, liftIO)
 import Text.Shakespeare.I18N (RenderMessage)
+import Control.Monad (liftM)
 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)
@@ -75,14 +69,10 @@ import qualified Text.Hamlet as NP
 import Data.Text.Lazy.Builder (fromLazyText)
 import Text.Blaze.Html (toHtml, preEscapedToMarkup)
 import qualified Data.Text.Lazy as TL
-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,32 +80,23 @@ 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
-instance ToWidget site Text where
-    toWidget = toWidget . toHtml
--- | @since 1.4.28
-instance ToWidget site TL.Text where
-    toWidget = toWidget . toHtml
--- | @since 1.4.28
-instance ToWidget site TB.Builder where
-    toWidget = toWidget . toHtml
 
 -- | Allows adding some CSS to the page with a specific media type.
 --
@@ -133,9 +114,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 +134,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 +150,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 +171,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 +179,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 +197,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 +205,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
@@ -366,7 +232,7 @@ rules = do
     let ur f = do
             let env = NP.Env
                     (Just $ helper [|getUrlRenderParams|])
-                    (Just $ helper [|fmap (toHtml .) getMessageRender|])
+                    (Just $ helper [|liftM (toHtml .) getMessageRender|])
             f env
     return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
 
@@ -389,10 +255,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 = fmap fixCss $ gwdCss gwd
+    , gwdJavascript = fmap fixJS $ gwdJavascript gwd
+    , gwdHead = fixHead $ gwdHead gwd
+    }
+  where
+    fixRender f route params = f (tp route) params
+
+    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/bench/THHelper.hs

@@ -1,24 +0,0 @@
-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
-module THHelper where
-
-import Language.Haskell.TH.Syntax
-import Data.Char (toLower)
-import Yesod.Routes.TH
-import Yesod.Routes.Parse
-
-settings = MkDispatchSettings
-    [|\w x y z -> (w, x, y, z)|]
-    [|undefined|]
-    [|fst|]
-    [|\x (_, y) -> (x, y)|]
-    [|snd|]
-    [|Nothing|]
-    [|Nothing|]
-    (\(Just method) name -> return $ VarE $ mkName $ map toLower method ++ name)
-
-resources = [parseRoutes|
-/ HomeR GET
-/foo FooR GET
-/bar/#Int BarR GET
-/baz BazR GET
-|]

yesod-core/bench/non-th.hs

@@ -1,75 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-import Yesod.Routes.Dispatch
-import Data.Text (Text, words)
-import Prelude hiding (words)
-import Web.PathPieces
-import Criterion.Main
-import Control.DeepSeq
-import Control.Monad (forM_, unless)
-
-data TestRoute = Foo | Bar !Int | Baz
-    deriving Eq
-instance NFData TestRoute
-
-samples = take 10000 $ cycle
-    [ words "foo"
-    , words "foo bar"
-    , words ""
-    , words "bar baz"
-    , words "bar 4"
-    , words "bar 1234566789"
-    , words "baz"
-    , words "baz 4"
-    , words "something else"
-    ]
-
-simple :: [Text] -> Maybe TestRoute
-simple ["foo"] = Just Foo
-simple ["bar", x] = fmap Bar (fromPathPiece x)
-simple ["baz"] = Just Baz
-simple ["FOO"] = Just Foo
-simple ["BAR", x] = fmap Bar (fromPathPiece x)
-simple ["BAZ"] = Just Baz
-simple ["Foo"] = Just Foo
-simple ["Bar", x] = fmap Bar (fromPathPiece x)
-simple ["Baz"] = Just Baz
-simple ["Xfoo"] = Just Foo
-simple ["Xbar", x] = fmap Bar (fromPathPiece x)
-simple ["Xbaz"] = Just Baz
-simple ["XFOO"] = Just Foo
-simple ["XBAR", x] = fmap Bar (fromPathPiece x)
-simple ["XBAZ"] = Just Baz
-simple ["XFoo"] = Just Foo
-simple ["XBar", x] = fmap Bar (fromPathPiece x)
-simple ["XBaz"] = Just Baz
-simple _ = Nothing
-
-dispatch :: [Text] -> Maybe TestRoute
-dispatch = toDispatch
-    [ Route [Static "foo"] False (const (Just Foo))
-    , Route [Static "bar", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
-    , Route [Static "baz"] False (const (Just Baz))
-    , Route [Static "FOO"] False (const (Just Foo))
-    , Route [Static "BAR", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
-    , Route [Static "BAZ"] False (const (Just Baz))
-    , Route [Static "Foo"] False (const (Just Foo))
-    , Route [Static "Bar", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
-    , Route [Static "Baz"] False (const (Just Baz))
-    , Route [Static "Xfoo"] False (const (Just Foo))
-    , Route [Static "Xbar", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
-    , Route [Static "Xbaz"] False (const (Just Baz))
-    , Route [Static "XFOO"] False (const (Just Foo))
-    , Route [Static "XBAR", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
-    , Route [Static "XBAZ"] False (const (Just Baz))
-    , Route [Static "XFoo"] False (const (Just Foo))
-    , Route [Static "XBar", Dynamic] False (\[_, x] -> (fmap Bar (fromPathPiece x)))
-    , Route [Static "XBaz"] False (const (Just Baz))
-    ]
-
-main :: IO ()
-main = do
-    forM_ samples $ \sample -> unless (simple sample == dispatch sample) (error $ show sample)
-    defaultMain
-        [ bench "simple" $ nf (map simple) samples
-        , bench "dispatch" $ nf (map dispatch) samples
-        ]

yesod-core/bench/th.hs

@@ -1,68 +0,0 @@
-{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, TupleSections, ViewPatterns #-}
-import Yesod.Routes.TH
-import Yesod.Routes.Parse
-import THHelper
-import Language.Haskell.TH.Syntax
-import Criterion.Main
-import Data.Text (words)
-import Prelude hiding (words)
-import Control.DeepSeq
-import Yesod.Routes.TH.Simple
-import Test.Hspec
-import Control.Monad (forM_, unless)
-
-$(do
-    let (cons, decs) = mkRouteCons $ map (fmap parseType) resources
-    clause1 <- mkDispatchClause settings resources
-    clause2 <- mkSimpleDispatchClause settings resources
-    return $ concat
-        [ [FunD (mkName "dispatch1") [clause1]]
-        , [FunD (mkName "dispatch2") [clause2]]
-        , decs
-        , [DataD [] (mkName "Route") [] cons [''Show, ''Eq]]
-        ]
-    )
-
-instance NFData Route where
-    rnf HomeR = ()
-    rnf FooR = ()
-    rnf (BarR i) = i `seq` ()
-    rnf BazR = ()
-
-getHomeR :: Maybe Int
-getHomeR = Just 1
-
-getFooR :: Maybe Int
-getFooR = Just 2
-
-getBarR :: Int -> Maybe Int
-getBarR i = Just (i + 3)
-
-getBazR :: Maybe Int
-getBazR = Just 4
-
-samples = take 10000 $ cycle
-    [ words "foo"
-    , words "foo bar"
-    , words ""
-    , words "bar baz"
-    , words "bar 4"
-    , words "bar 1234566789"
-    , words "baz"
-    , words "baz 4"
-    , words "something else"
-    ]
-
-dispatch2a = dispatch2 `asTypeOf` dispatch1
-
-main :: IO ()
-main = do
-    forM_ samples $ \sample ->
-        unless (dispatch1 True (sample, "GET") == dispatch2a True (sample, "GET"))
-            (error $ show sample)
-    defaultMain
-        [ bench "dispatch1" $ nf (map (dispatch1 True . (, "GET"))) samples
-        , bench "dispatch2" $ nf (map (dispatch2a True . (, "GET"))) samples
-        , bench "dispatch1a" $ nf (map (dispatch1 True . (, "GET"))) samples
-        , bench "dispatch2a" $ nf (map (dispatch2a True . (, "GET"))) samples
-        ]

yesod-core/bench/widget.hs

@@ -1,24 +1,29 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
 -- | BigTable benchmark implemented using Hamlet.
 --
 {-# LANGUAGE QuasiQuotes #-}
 module Main where
 
-import Gauge.Main
+import Criterion.Main
 import Text.Hamlet
+import Numeric (showInt)
 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 Data.Int
+import Yesod.Core.Widget
+import Control.Monad.Trans.Writer
+import Control.Monad.Trans.RWS
+import Data.Functor.Identity
+import Yesod.Core.Types
+import Data.Monoid
+import Data.IORef
 
-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
@@ -29,7 +34,6 @@ main = defaultMain
     bigTableData = replicate rows [1..10]
     {-# NOINLINE bigTableData #-}
 
-bigTableHtml :: Show a => [[a]] -> Int64
 bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
 <table>
     $forall row <- rows
@@ -38,7 +42,6 @@ bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
                 <td>#{show cell}
 |]
 
-bigTableHamlet :: Show a => [[a]] ->  Int64
 bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
 <table>
     $forall row <- rows
@@ -47,8 +50,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>
     $forall row <- rows
@@ -61,9 +62,7 @@ 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 $ mconcat $ map row t
-bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t
   where
     row r = tr $ mconcat $ map (td . toHtml . show) r

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' }