Merge remote-tracking branch 'origin/master' into static-pages

.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

@@ -1,29 +1,8 @@
-*~
 *.o
 *.o_p
 *.hi
-dist/
-dist-stack/
-stack.yaml.lock
-.stack-work
+dist
 *.swp
 client_session_key.aes
 cabal-dev/
 yesod/foobar/
-.hsenv/
-.cabal-sandbox/
-cabal.sandbox.config
-/vendor/
-.shelly/
-tarballs/
-
-# useful when mounting into docker
-.cabal
-.ghc
-.stackage
-.bash_history
-
-# OS X
-.DS_Store
-*.yaml.lock
-dist-newstyle/

.gitmodules

@@ -0,0 +1,18 @@
+[submodule "scripts"]
+	path = scripts
+	url = git://github.com/yesodweb/scripts.git
+[submodule "authenticate"]
+	path = authenticate
+	url = https://github.com/yesodweb/authenticate.git
+[submodule "http-conduit"]
+	path = http-conduit
+	url = https://github.com/snoyberg/http-conduit
+[submodule "xml"]
+	path = xml
+	url = https://github.com/snoyberg/xml
+[submodule "crypto-conduit"]
+	path = crypto-conduit
+	url = https://github.com/snoyberg/crypto-conduit
+[submodule "yaml"]
+	path = yaml
+	url = https://github.com/snoyberg/yaml

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,20 +1,25 @@
-Copyright (c) 2012-2017 Michael Snoyman, http://www.yesodweb.com/
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
 
-Permission is hereby granted, free of charge, to any person obtaining
-a copy of this software and associated documentation files (the
-"Software"), to deal in the Software without restriction, including
-without limitation the rights to use, copy, modify, merge, publish,
-distribute, sublicense, and/or sell copies of the Software, and to
-permit persons to whom the Software is furnished to do so, subject to
-the following conditions:
+Copyright 2010, Michael Snoyman. All rights reserved.
 
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
 
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -1,7 +1,3 @@
-![Tests](https://github.com/yesodweb/yesod/workflows/Tests/badge.svg)
-
-# Yesod Web Framework
-
 An advanced web framework using the Haskell programming language. Featuring:
 
   * safety & security guaranteed at compile time
@@ -11,51 +7,119 @@ An advanced web framework using the Haskell programming language. Featuring:
     * techniques for constant-space memory consumption
   * asynchronous IO
     * this is built in to the Haskell programming language (like Erlang)
+    * handles a greater concurrent load than any other web application server
 
-## Getting Started
+## Learn more: http://yesodweb.com/
 
-Learn more about Yesod on [its main website](http://www.yesodweb.com/). If you
-want to get started using Yesod, we strongly recommend the [quick start
-guide](http://www.yesodweb.com/page/quickstart), based on [the Haskell build
-tool stack](https://github.com/commercialhaskell/stack#readme).
+## Installation: http://www.yesodweb.com/page/five-minutes
 
-Here's a minimal example!
+    cabal update && cabal install yesod
 
-```haskell
-{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies #-}
+## Create a new project after installing
 
-import Yesod
+    yesod init
 
-data App = App -- Put your config, database connection pool, etc. in here.
 
--- Derive routes and instances for App.
-mkYesod "App" [parseRoutes|
-/ HomeR GET
-|]
+## Using cabal-dev
 
-instance Yesod App -- Methods in here can be overridden as needed.
+cabal-dev creates a sandboxed environment for an individual cabal package.
+Your application is a cabal package and you should use cabal-dev with your Yesod application.
+Instead of using the `cabal` command, use the `cabal-dev` command.
 
--- The handler for the GET request at /, corresponds to HomeR.
-getHomeR :: Handler Html
-getHomeR = defaultLayout [whamlet|Hello World!|]
+Use `yesod-devel --dev` when developing your application.
 
-main :: IO ()
-main = warp 3000 App
-```
+## Installing the latest development version from github
 
-To read about each of the concepts in use above (routing, handlers,
-linking, JSON), in detail, visit
-[Basics in the Yesod book](https://www.yesodweb.com/book/basics#basics_routing).
+Yesod is broken up into 4 separate code repositories each built upon many smaller packages.
 
-## Hacking on Yesod
+Install conflicts are unfortunately common in Haskell development.
+However, we can prevent most of them by using some extra tools.
+This will require a little up-front reading and learning, but save you from a lot of misery in the long-run.
+See the above explanation of cabal-dev, and below of virthualenv.
 
-Yesod consists mostly of four repositories:
+Please note that cabal-dev will not work in a virthualenv shell - you can't use both at the same time.
 
-```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
-```
+### virthualenv
 
-Each repository can be built with `stack build`.
+virthualenv will not work on Windows - Windows users should use only cabal-dev.
+
+To just install Yesod from github, we only need cabal-dev. However, cabal-dev may be more hassle than it is worth when hacking on Yesod.
+
+We recommend using [virthualenv](http://hackage.haskell.org/package/virthualenv) when hacking on Yesod.
+This is optional, but prevents your custom build of Yesod from interfering with your currently installed cabal packages.
+virthualenv creates an isolated environment like cabal-dev.
+cabal-dev by default isolates a single cabal package, but virthualenv isolates multiple packages together.
+cabal-dev can isolate multiple packages together by using the -s sandbox argument
+
+virthualenv works at the shell level, so every shell must activate the virthualenv.
+
+### cabal-src
+
+Michael Snoyman just released the cabal-src tool, which helps resolve dependency conflicts when installing local packages.
+Whenever you would use `cabal install` for a local package, use `cabal-src-install` instead. Our installer script now uses cabal-src-install when it is available.
+
+### Building Yesod
+
+~~~ { .bash }
+# update your package database if you haven't recently
+cabal update
+# install required libraries
+cabal install Cabal cabal-install cabal-src virthualenv
+
+# clone and install all repos
+# see below about first using virthualenv before running ./scripts/install
+for repo in hamlet persistent wai yesod; do
+  git clone http://github.com/yesodweb/$repo
+  (
+    cd $repo
+    git submodule update --init
+    ./scripts/install
+  )
+done
+~~~
+
+### Hacking on Yesod
+
+To prevent Yesod from conflicting with your other installs, you should use virthualenv, although it is optional.
+
+#### virthualenv
+
+~~~ { .bash }
+cabal update
+cabal install virthualenv
+cd yesodweb # the folder where you put the yesod, persistent, hamlet & wai repos
+virthualenv --name=yesod
+. .virthualenv/bin/activate
+~~~
+
+#### individual cabal packages
+
+~~~ { .bash }
+# install and test all packages
+./scripts/install
+
+# 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
+~~~
+
+#### cabal-dev
+
+cabal-dev works very well if you are working on a single package, but it can be very cumbersome to work on multiple packages at once.
+
+### Use your development version of Yesod in your application
+
+Note that we have recommended to you to install Yesod into a sandboxed virthualenv environment.
+This is great for development, but when you want to use these development versions in your application that means they are not available through your user/global cabal database for your application.
+You should just continue to use your yesod virthualenv shell for your application.
+
+You can also use `cabal-dev install` to retrieve these packages.
+cd to your application directory, and the reference the source list.
+
+~~~ { .bash }
+cabal-dev install /path/to/yesodweb/yesod/*(/)
+~~~

ReleaseNotes.md

@@ -0,0 +1,12 @@
+Yesod 0.10
+=======================
+
+* Replace lift with liftHandler and liftWidget
+* No more GGHandler or GGWidget
+* No more liftIOHandler
+* Enumerators are gone, in come conduits, now you can catch exceptions!
+* Move from pool to resource-pool
+* Rework of the redirect system
+* Configure database parameters via environment variables.
+* Fully reworked routing, much more efficient.
+* Cleaned up EntityDef, making it more resilient to renamings.

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/appcache/AppCache.hs

@@ -1,60 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
-module AppCache where
-
-import           Control.Monad              (when)
-import           Control.Monad.Trans.Writer
-import           Data.Hashable              (hashWithSalt)
-import           Data.List                  (intercalate)
-import qualified Data.Set                   as Set
-import           Data.Text                  (Text)
-import           Data.Text                  (pack)
-import           Language.Haskell.TH.Syntax
-import           Yesod.Core
-import           Yesod.Routes.TH
-
-newtype AppCache = AppCache { unAppCache :: Text }
-
-appCache :: [ResourceTree String] -> Q Exp
-appCache trees = do
-    piecesSet <- execWriterT $ mapM_ (goTree id) trees
-    let body = unlines $ map toPath $ Set.toList piecesSet
-        hash = hashWithSalt 0 body
-        total = concat
-            [ "CACHE MANIFEST\n# Version: "
-            , show hash
-            , "\n\nCACHE:\n"
-            , body
-            ]
-    [|return (AppCache (pack total))|]
-  where
-    toPath [] = "/"
-    toPath x = concatMap ('/':) x
-
-goTree :: Monad m
-       => ([String] -> [String])
-       -> ResourceTree String
-       -> WriterT (Set.Set [String]) m ()
-goTree front (ResourceLeaf res) = do
-    pieces' <- goPieces (resourceName res) $ resourcePieces res
-    when ("CACHE" `elem` resourceAttrs res) $
-        tell $ Set.singleton $ front pieces'
-goTree front (ResourceParent name pieces trees) = do
-    pieces' <- goPieces name pieces
-    mapM_ (goTree $ front . (pieces' ++)) trees
-
-goPieces :: Monad m => String -> [(CheckOverlap, Piece String)] -> m [String]
-goPieces name =
-    mapM (goPiece . snd)
-  where
-    goPiece (Static s) = return s
-    goPiece (Dynamic _) = fail $ concat
-        [ "AppCache only applies to fully-static paths, but "
-        , name
-        , " has dynamic pieces."
-        ]
-
-instance ToContent AppCache where
-    toContent = toContent . unAppCache
-instance ToTypedContent AppCache where
-    toTypedContent = TypedContent "text/cache-manifest" . toContent

demo/appcache/Main.hs

@@ -1,23 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
-import           AppCache
-import           Routes
-import           Yesod.Core
-
-instance Yesod App
-
-mkYesodDispatch "App" resourcesApp
-
-getHomeR :: Handler String
-getHomeR = return "Hello"
-
-getSomethingR :: Handler String
-getSomethingR = return "Hello"
-
-getAppCacheR :: Handler AppCache
-getAppCacheR = $(appCache resourcesApp)
-
-main :: IO ()
-main = warp 3000 App

demo/appcache/Routes.hs

@@ -1,15 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
-module Routes where
-
-import           Yesod.Core
-
-data App = App
-
-mkYesodData "App" [parseRoutes|
-/ HomeR GET
-/some/thing SomethingR GET !CACHE
-/appcache AppCacheR GET
-|]

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

@@ -1,21 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-import Yesod.Core
-import Data.Aeson
-import Data.Monoid ((<>))
-import Data.Text (Text, pack)
-
-people :: [(Text, Int)]
-people = [("Alice", 25), ("Bob", 43), ("Charlie", 37)]
-
-main = warp 3000 $ liteApp $ do
-    onStatic "people" $ dispatchTo getPeople
-    onStatic "person" $ withDynamic $ dispatchTo . getPerson
-
-getPeople = return $ toJSON $ map fst people
-
-getPerson name =
-    case lookup name people of
-        Nothing -> notFound
-        Just age -> selectRep $ do
-            provideRep $ return $ object ["name" .= name, "age" .= age]
-            provideRep $ return $ name <> " is " <> pack (show age) <> " years old"

demo/streaming-db/streaming-db.hs

@@ -1,67 +0,0 @@
-{-# LANGUAGE EmptyDataDecls    #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE GADTs             #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TypeFamilies      #-}
-import           Control.Monad.Logger    (runNoLoggingT)
-import           Data.Conduit            (awaitForever, runResourceT, ($=))
-import           Data.Text               (Text)
-import           Database.Persist.Sqlite (ConnectionPool, SqlPersist,
-                                          SqliteConf (..), runMigration,
-                                          runSqlPool)
-import           Database.Persist.Store  (createPoolConfig)
-import           Yesod.Core
-import           Yesod.Persist
-
-share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|
-Person
-    name Text
-|]
-
-data App = App
-    { appConfig :: SqliteConf
-    , appPool   :: ConnectionPool
-    }
-
-mkYesod "App" [parseRoutes|
-/ HomeR GET
-|]
-
-instance Yesod App
-instance YesodPersist App where
-    type YesodPersistBackend App = SqlPersist
-    runDB = defaultRunDB appConfig appPool
-instance YesodPersistRunner App where
-    getDBRunner = defaultGetDBRunner appPool
-
-getHomeR :: Handler TypedContent
-getHomeR = do
-    runDB $ do
-        runMigration migrateAll
-        deleteWhere ([] :: [Filter Person])
-        insert_ $ Person "Charlie"
-        insert_ $ Person "Alice"
-        insert_ $ Person "Bob"
-    respondSourceDB typePlain $ selectSource [] [Asc PersonName] $= awaitForever toBuilder
-  where
-    toBuilder (Entity _ (Person name)) = do
-        sendChunkText name
-        sendChunkText "\n"
-        sendFlush
-
-main :: IO ()
-main = do
-    let config = SqliteConf ":memory:" 1
-    pool <- createPoolConfig config
-    runNoLoggingT $ runResourceT $ flip runSqlPool pool $ do
-        runMigration migrateAll
-        deleteWhere ([] :: [Filter Person])
-        insert_ $ Person "Charlie"
-        insert_ $ Person "Alice"
-        insert_ $ Person "Bob"
-    warp 3000 App
-        { appConfig = config
-        , appPool = pool
-        }

demo/streaming/streaming.hs

@@ -1,48 +0,0 @@
-{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies #-}
-import Yesod.Core
-import Data.Conduit
-import qualified Data.Conduit.Binary as CB
-import Control.Concurrent.Lifted (threadDelay)
-import Data.Monoid ((<>))
-import qualified Data.Text as T
-import Control.Monad (forM_)
-
-data App = App
-
-mkYesod "App" [parseRoutes|
-/ HomeR GET
-|]
-
-instance Yesod App
-
-fibs :: [Int]
-fibs = 1 : 1 : zipWith (+) fibs (tail fibs)
-
-getHomeR :: Handler TypedContent
-getHomeR = do
-    value <- lookupGetParam "x"
-    case value of
-        Just "file" -> respondSource typePlain $ do
-            sendChunkText "Going to read a file\n\n"
-            CB.sourceFile "streaming.hs" $= awaitForever sendChunkBS
-            sendChunkText "Finished reading the file\n"
-        Just "fibs" -> respondSource typePlain $ do
-            forM_ fibs $ \fib -> do
-                $logError $ "Got fib: " <> T.pack (show fib)
-                sendChunkText $ "Next fib is: " <> T.pack (show fib) <> "\n"
-                yield Flush
-                sendFlush
-                threadDelay 1000000
-        _ -> fmap toTypedContent $ defaultLayout $ do
-            setTitle "Streaming"
-            [whamlet|
-                <p>Notice how in the code above we perform selection before starting the stream.
-                <p>Anyway, choose one of the options below.
-                <ul>
-                    <li>
-                        <a href=?x=file>Read a file
-                    <li>
-                        <a href=?x=fibs>See the fibs
-            |]
-
-main = warp 3000 App

demo/subsite/Main.hs

@@ -1,40 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
-module Main where
-
-import           Control.Applicative ((<$>))
-import           Wiki
-import           Yesod
-
--- A very simple App, doesn't do anything except provide the Wiki.
-data App = App
-    { appWiki :: Wiki
-    }
-
-mkYesod "App" [parseRoutes|
-/ HomeR GET
-/wiki WikiR Wiki appWiki
-|]
-
-instance Yesod App
-instance YesodWiki App -- Just use the defaults
-instance RenderMessage App FormMessage where
-    renderMessage _ _ = defaultFormMessage
-
-getHomeR :: Handler Html
-getHomeR = defaultLayout
-    [whamlet|
-        <p>
-            Welcome to my test application.
-            The application is pretty boring.
-            You probably want to go to
-            <a href=@{WikiR WikiHomeR}>the wiki#
-            .
-    |]
-
-main :: IO ()
-main = do
-    app <- App <$> newWiki
-    warp 3000 app

demo/subsite/Wiki.hs

@@ -1,147 +0,0 @@
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Define the dispatch for a Wiki. You should probably start off by reading
--- WikiRoutes.
-module Wiki
-    ( module WikiRoutes
-    ) where
-
-import           Control.Applicative ((<$>))
-import           Control.Monad       (unless)
-import           Data.IORef.Lifted   (readIORef, atomicModifyIORef)
-import           Data.Map            (Map)
-import qualified Data.Map            as Map
-import           Data.Text           (Text)
-import           WikiRoutes
-import           Yesod
-
--- | A subsite needs to be an instance of YesodSubDispatch, which states how to
--- dispatch. By using constraints, we can make requirements of our master site.
--- In this example, we're saying that the master site must be an instance of
--- YesodWiki.
-instance YesodWiki master => YesodSubDispatch Wiki (HandlerT master IO) where
-    -- | This is all the TH magic for dispatch. WikiRoutes provides the
-    -- resourcesWiki value automatically, and mkYesodSubDispatch will generate
-    -- a dispatch function that will call out to the appropriate handler
-    -- functions.
-    yesodSubDispatch = $(mkYesodSubDispatch resourcesWiki)
-
--- | Helper type synonym to be used below.
-type WikiHandler a = forall master. YesodWiki master
-                  => HandlerT Wiki (HandlerT master IO) a
-
-------------- Helper functions
-
--- | Get all of the content in the Wiki.
-getContent :: WikiHandler (Map Texts Textarea)
-getContent = getYesod >>= readIORef . wikiContent
-
--- | Put a single new value into the Wiki.
-putContent :: Texts -> Textarea -> WikiHandler ()
-putContent k v = do
-    refMap <- wikiContent <$> getYesod
-    atomicModifyIORef refMap $ \m -> (Map.insert k v m, ())
-
--- | Gets the homepage, which lists all of the pages available.
-getWikiHomeR :: WikiHandler TypedContent
-getWikiHomeR = do
-    content <- getContent
-    -- We use the new selectRep/provideRep functionality to provide either an
-    -- HTML or JSON representation of the page. You could just as easily
-    -- provide YAML, plain text, RSS, or anything else.
-    selectRep $ do
-        provideRep $ do
-            -- We'll use toParent to convert Wiki routes into our master site
-            -- routes.
-            toParent <- getRouteToParent
-
-            -- Run the master site's defaultLayout to style the page.
-            lift $ defaultLayout
-                [whamlet|
-                    <p>This wiki has the following pages:
-                    <ul>
-                        $forall page <- Map.keys content
-                            <li>
-                                -- Notice the usage of toParent!
-                                <a href=@{toParent $ WikiReadR page}>#{show page}
-                |]
-        -- You provide a JSON representation just by returning a JSON value.
-        -- aeson's toJSON make it easy to convert a list of values into JSON.
-        provideRep $ return $ toJSON $ Map.keys content
-
-getWikiReadR :: Texts -> WikiHandler TypedContent
-getWikiReadR page = do
-    content <- getContent
-    selectRep $ do
-        provideRep $
-            case Map.lookup page content of
-                Nothing -> do
-                    setMessage $ "Page does not exist, please create it."
-
-                    -- We don't need to convert or lift here: we're using a
-                    -- route from our subsite, and redirect lives in our
-                    -- subsite.
-                    redirect $ WikiEditR page
-                Just t -> do
-                    toParent <- getRouteToParent
-
-                    -- Notice that we lift the canEditPage function from the
-                    -- master site.
-                    canEdit <- lift $ canEditPage page
-
-                    lift $ defaultLayout
-                        [whamlet|
-                            <article>#{t}
-                            $if canEdit
-                                <p>
-                                    <a href=@{toParent $ WikiEditR page}>Edit
-                        |]
-        provideRep $ return $ toJSON $
-            case Map.lookup page content of
-                -- Our HTML representation sends a redirect if the page isn't
-                -- found, but our JSON representation just returns a JSON value
-                -- instead.
-                Nothing -> object ["error" .= ("Page not found" :: Text)]
-                Just (Textarea t) -> object ["content" .= t]
-
-getWikiEditR :: Texts -> WikiHandler Html
-getWikiEditR page = do
-    canEdit <- lift $ canEditPage page
-    unless canEdit $ permissionDenied "You do not have permissions to edit this page."
-
-    content <- getContent
-    let form = renderTable
-             $ areq textareaField "Content" (Map.lookup page content)
-
-    -- We need to use lift here since the widget will be used below.
-    -- Practically speaking, this means that we'll be rendering form messages
-    -- using the master site's translation functions.
-    ((res, widget), enctype) <- lift $ runFormPost form
-
-    case res of
-        FormSuccess t -> do
-            putContent page t
-            setMessage "Content updated"
-            redirect $ WikiEditR page
-        _ -> do
-            toParent <- getRouteToParent
-            lift $ defaultLayout
-                [whamlet|
-                    <p>
-                        <a href=@{toParent $ WikiReadR page}>Read page
-                    <form method=post action=@{toParent $ WikiEditR page} enctype=#{enctype}>
-                        <table>
-                            ^{widget}
-                            <tr>
-                                <td colspan=2>
-                                    <button>Update page
-                |]
-
-postWikiEditR :: Texts -> WikiHandler Html
-postWikiEditR = getWikiEditR

demo/subsite/WikiRoutes.hs

@@ -1,41 +0,0 @@
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
--- | Define our Wiki data type, routes, and the YesodWiki typeclass. Due to the
--- GHC stage restriction, the routes must be declared in a separate module from
--- our dispatch instance.
-module WikiRoutes where
-
-import           Control.Monad          (liftM)
-import           Control.Monad.IO.Class (MonadIO)
-import           Data.IORef             (IORef, newIORef)
-import           Data.Map               (Map, empty)
-import           Yesod
-
--- | Simple Wiki datatype: just store a Map from Wiki path to the contents of
--- the page.
-data Wiki = Wiki
-    { wikiContent :: IORef (Map Texts Textarea)
-    }
-
--- | 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
--- processing user input.
-class (RenderMessage master FormMessage, Yesod master) => YesodWiki master where
-    -- | Write protection. By default, no protection.
-    canEditPage :: Texts -> HandlerT master IO Bool
-    canEditPage _ = return True
-
--- | Define our routes. We'll have a homepage that lists all of the pages, a
--- read route for reading a page, and an edit route.
-mkYesodSubData "Wiki" [parseRoutes|
-/ WikiHomeR GET
-/read/*Texts WikiReadR GET
-/edit/*Texts WikiEditR GET POST
-|]
-
--- | A convenience function for creating an empty Wiki.
-newWiki :: MonadIO m => m Wiki
-newWiki = Wiki `liftM` liftIO (newIORef empty)

package-list.sh

@@ -0,0 +1,13 @@
+#!/bin/bash
+
+pkgs=(      ./yesod-routes
+            ./yesod-core
+            ./yesod-json
+            ./yesod-static
+            ./yesod-persistent
+            ./yesod-newsfeed
+            ./yesod-form
+            ./yesod-auth
+            ./yesod-sitemap
+            ./yesod-default
+            ./yesod                 )

scripts

@@ -0,0 +1 @@
+Subproject commit d4cb555ca5fd6bc67f7da484a63d1fcdb149eac9

sources.txt

@@ -0,0 +1,10 @@
+yesod-core
+yesod-json
+yesod-static
+yesod-persistent
+yesod-newsfeed
+yesod-form
+yesod-auth
+yesod-sitemap
+yesod-default
+yesod

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-kerberos/LICENSE

@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2010, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

yesod-auth-kerberos/Setup.lhs

@@ -2,6 +2,7 @@
 
 > module Main where
 > import Distribution.Simple
+> import System.Cmd (system)
 
 > main :: IO ()
 > main = defaultMain

yesod-auth-kerberos/Yesod/Auth/Kerberos.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | In-built kerberos authentication for Yesod.
+--
+-- Please note that all configuration should have been done
+-- manually on the machine prior to running the code.
+--
+-- On linux machines the configuration might be in /etc/krb5.conf.
+-- It's worth checking if the Kerberos service provider (e.g. your university)
+-- already provide a complete configuration file.
+--
+-- Be certain that you can manually login from a shell by typing
+--
+-- > kinit username
+--
+-- If you fill in your password and the program returns no error code,
+-- then your kerberos configuration is setup properly.
+-- Only then can this module be of any use.
+module Yesod.Auth.Kerberos
+    ( authKerberos,
+      genericAuthKerberos,
+      KerberosConfig(..),
+      defaultKerberosConfig
+    ) where
+
+#include "qq.h"
+
+import Yesod.Auth
+import Yesod.Auth.Message
+import Web.Authenticate.Kerberos
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.Hamlet
+import Yesod.Handler
+import Yesod.Widget
+import Control.Monad.IO.Class (liftIO)
+import Yesod.Form
+import Control.Applicative ((<$>), (<*>))
+
+data KerberosConfig = KerberosConfig {
+    -- | When a user gives username x, f(x) will be passed to Kerberos
+    usernameModifier :: Text -> Text
+    -- | When a user gives username x, f(x) will be passed to Yesod
+  , identifierModifier :: Text -> Text
+  }
+
+-- | A configuration where the username the user provides is the one passed
+-- to both kerberos and yesod
+defaultKerberosConfig :: KerberosConfig
+defaultKerberosConfig = KerberosConfig id id
+
+-- | A configurable version of 'authKerberos'
+genericAuthKerberos :: YesodAuth m => KerberosConfig -> AuthPlugin m
+genericAuthKerberos config = AuthPlugin "kerberos" dispatch $ \tm -> addHamlet
+    [QQ(hamlet)|
+    <div id="header">
+        <h1>Login
+
+    <div id="login">
+        <form method="post" action="@{tm login}">
+            <table>
+                <tr>
+                    <th>Username:
+                    <td>
+                        <input id="x" name="username" autofocus="" required>
+                <tr>
+                    <th>Password:
+                    <td>
+                        <input type="password" name="password" required>
+                <tr>
+                    <td>&nbsp;
+                    <td>
+                        <input type="submit" value="Login">
+
+            <script>
+                if (!("autofocus" in document.createElement("input"))) {
+                    document.getElementById("x").focus();
+                }
+|]
+  where
+    dispatch "POST" ["login"] = postLoginR config >>= sendResponse
+    dispatch _ _              = notFound
+
+login :: AuthRoute
+login = PluginR "kerberos" ["login"]
+
+-- | Kerberos with 'defaultKerberosConfig'
+authKerberos :: YesodAuth m => AuthPlugin m
+authKerberos = genericAuthKerberos defaultKerberosConfig
+
+-- | Handle the login form
+postLoginR :: (YesodAuth y) => KerberosConfig -> GHandler Auth y ()
+postLoginR config = do
+    (mu,mp) <- runInputPost $ (,)
+        <$> iopt textField "username"
+        <*> iopt textField "password"
+
+    let errorMessage (message :: Text) = do
+        setMessage [QQ(shamlet)|Error: #{message}|]
+        toMaster <- getRouteToMaster
+        redirect $ toMaster LoginR
+
+    case (mu,mp) of
+        (Nothing, _      ) -> do
+            mr <- getMessageRender
+            errorMessage $ mr PleaseProvideUsername
+        (_      , Nothing) -> do
+            mr <- getMessageRender
+            errorMessage $ mr PleaseProvidePassword
+        (Just u , Just p ) -> do
+          result <- liftIO $ loginKerberos (usernameModifier config u) p
+          case result of
+            Ok -> do
+                let creds = Creds
+                      { credsIdent  = identifierModifier config u
+                      , credsPlugin = "Kerberos"
+                      , credsExtra  = []
+                      }
+                setCreds True creds
+            kerberosError -> errorMessage (T.pack $ show kerberosError)
+

yesod-auth-kerberos/include/qq.h

@@ -0,0 +1,10 @@
+
+-- CPP macro which choses which quasyquotes syntax to use depending
+-- on GHC version.
+--
+-- QQ stands for quasyquote.
+#if GHC7
+# define QQ(x) x
+#else
+# define QQ(x) $x
+#endif

yesod-auth-kerberos/yesod-auth-kerberos.cabal

@@ -0,0 +1,39 @@
+name:            yesod-auth-kerberos
+version:         0.8.0
+license:         BSD3
+license-file:    LICENSE
+author:          Arash Rouhani
+maintainer:      Arash Rouhani
+synopsis:        Kerberos Authentication for Yesod.
+category:        Web, Yesod
+stability:       Stable
+cabal-version:   >= 1.6.0
+build-type:      Simple
+homepage:        http://www.yesodweb.com/
+extra-source-files: include/qq.h
+description:     Kerberos Authentication for Yesod.
+
+flag ghc7
+
+library
+    if flag(ghc7)
+        build-depends:   base                >= 4.3      && < 5
+        cpp-options:     -DGHC7
+    else
+        build-depends:   base                >= 4        && < 4.3
+    build-depends:   authenticate-kerberos   >= 1.0       && < 1.1
+                   , bytestring              >= 0.9.1.4   && < 0.10
+                   , yesod-core              >= 0.10      && < 0.11
+                   , yesod-auth              >= 0.8       && < 0.9
+                   , text                    >= 0.7       && < 0.12
+                   , hamlet                  >= 0.10      && < 0.11
+                   , yesod-form              >= 0.4       && < 0.5
+                   , transformers            >= 0.2.2     && < 0.3
+
+    exposed-modules: Yesod.Auth.Kerberos
+    ghc-options:     -Wall
+    include-dirs: include
+
+source-repository head
+  type:     git
+  location: https://github.com/yesodweb/yesod

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/LICENSE

@@ -1,20 +1,25 @@
-Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
 
-Permission is hereby granted, free of charge, to any person obtaining
-a copy of this software and associated documentation files (the
-"Software"), to deal in the Software without restriction, including
-without limitation the rights to use, copy, modify, merge, publish,
-distribute, sublicense, and/or sell copies of the Software, and to
-permit persons to whom the Software is furnished to do so, subject to
-the following conditions:
+Copyright 2010, Michael Snoyman. All rights reserved.
 
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
 
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

yesod-auth-oauth/README.md

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

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

@@ -1,163 +1,89 @@
-{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings #-}
+{-# OPTIONS_GHC -fwarn-unused-imports #-}
 module Yesod.Auth.OAuth
     ( authOAuth
     , oauthUrl
     , authTwitter
-    , authTwitterUsingUserId
     , twitterUrl
-    , authTumblr
-    , tumblrUrl
-    , module Web.Authenticate.OAuth
     ) where
-import           Control.Applicative      as A ((<$>), (<*>))
-import           Control.Arrow            ((***))
-import           UnliftIO.Exception
-import           Control.Monad.IO.Class
-import           Data.ByteString          (ByteString)
-import           Data.Maybe
-import           Data.Text                (Text)
-import qualified Data.Text                as T
-import           Data.Text.Encoding       (decodeUtf8With, encodeUtf8)
-import           Data.Text.Encoding.Error (lenientDecode)
-import           Web.Authenticate.OAuth
-import           Yesod.Auth
-import           Yesod.Form
-import           Yesod.Core
 
-data YesodOAuthException = CredentialError String Credential
-                         | SessionError String
-                           deriving Show
+#include "qq.h"
 
-instance Exception YesodOAuthException
+import Yesod.Auth
+import Yesod.Form
+import Yesod.Handler
+import Yesod.Widget
+import Text.Hamlet (shamlet)
+import Web.Authenticate.OAuth
+import Data.Maybe
+import Data.String
+import Data.ByteString.Char8 (pack)
+import Control.Arrow ((***))
+import Data.Text (Text, unpack)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
+import Data.ByteString (ByteString)
+import Control.Applicative ((<$>), (<*>))
 
 oauthUrl :: Text -> AuthRoute
 oauthUrl name = PluginR name ["forward"]
 
-authOAuth :: forall master. YesodAuth master
-          => OAuth                        -- ^ 'OAuth' data-type for signing.
-          -> (Credential -> IO (Creds master)) -- ^ How to extract ident.
-          -> AuthPlugin master
-authOAuth oauth mkCreds = AuthPlugin name dispatch login
+authOAuth :: YesodAuth m =>
+             Text -- ^ Service Name
+          -> String -- ^ OAuth Parameter Name to use for identify
+          -> String -- ^ Request URL
+          -> String -- ^ Access Token URL
+          -> String -- ^ Authorize URL
+          -> String -- ^ Consumer Key
+          -> String -- ^ Consumer Secret
+          -> AuthPlugin m
+authOAuth name ident reqUrl accUrl authUrl key sec = 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
+    oauth = OAuth { oauthServerName = unpack name, oauthRequestUri = reqUrl
+                  , oauthAccessTokenUri = accUrl, oauthAuthorizeUri = authUrl
+                  , oauthSignatureMethod = HMACSHA1
+                  , oauthConsumerKey = fromString key, oauthConsumerSecret = fromString sec
+                  , oauthCallback = Nothing
+                  , oauthRealm = Nothing
+                  }
     dispatch "GET" ["forward"] = do
         render <- getUrlRender
-        tm <- getRouteToParent
+        tm <- getRouteToMaster
         let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
-        manager <- authHttpManager
-        tok <- getTemporaryCredential oauth' manager
-        setSession oauthSessionName $ lookupTokenSecret tok
+        master <- getYesod
+        tok <- lift $ getTemporaryCredential oauth' (authHttpManager master)
         redirect $ authorizeUrl oauth' tok
     dispatch "GET" [] = do
-      tokSec <- lookupSession oauthSessionName >>= \case
-        Just t -> return t
-        Nothing -> liftIO $ fail "lookupSession could not find session"
-      deleteSession oauthSessionName
-      reqTok <-
-        if oauthVersion oauth == OAuth10
-          then do
-            oaTok  <- runInputGet $ ireq textField "oauth_token"
-            return $ Credential [ ("oauth_token", encodeUtf8 oaTok)
-                                , ("oauth_token_secret", encodeUtf8 tokSec)
+        (verifier, oaTok) <- runInputGet $ (,)
+            <$> ireq textField "oauth_verifier"
+            <*> ireq textField "oauth_token"
+        let reqTok = Credential [ ("oauth_verifier", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok)
                                 ]
-          else do
-            (verifier, oaTok) <-
-                runInputGet $ (,) A.<$> ireq textField "oauth_verifier"
-                                  A.<*> ireq textField "oauth_token"
-            return $ Credential [ ("oauth_verifier", encodeUtf8 verifier)
-                                , ("oauth_token", encodeUtf8 oaTok)
-                                , ("oauth_token_secret", encodeUtf8 tokSec)
-                                ]
-      manager <- authHttpManager
-      accTok <- getAccessToken oauth reqTok manager
-      creds  <- liftIO $ mkCreds accTok
-      setCredsRedirect creds
+        master <- getYesod
+        accTok <- lift $ getAccessToken oauth reqTok (authHttpManager master)
+        let crId = decodeUtf8With lenientDecode $ fromJust $ lookup (pack ident) $ unCredential accTok
+            creds = Creds name crId $ map (bsToText *** bsToText ) $ unCredential accTok
+        setCreds True creds
     dispatch _ _ = notFound
-
     login tm = do
-        render <- getUrlRender
+        render <- lift getUrlRender
         let oaUrl = render $ tm $ oauthUrl name
-        [whamlet| <a href=#{oaUrl}>Login via #{name} |]
+        addHtml
+          [QQ(shamlet)| <a href=#{oaUrl}>Login with #{name} |]
 
-mkExtractCreds :: 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
-             => ByteString -- ^ Consumer Key
-             -> ByteString -- ^ Consumer Secret
-             -> String
-             -> AuthPlugin m
-authTwitter' key secret idName = authOAuth
-                (newOAuth { oauthServerName      = "twitter"
-                          , oauthRequestUri      = "https://api.twitter.com/oauth/request_token"
-                          , oauthAccessTokenUri  = "https://api.twitter.com/oauth/access_token"
-                          , oauthAuthorizeUri    = "https://api.twitter.com/oauth/authorize"
-                          , oauthSignatureMethod = HMACSHA1
-                          , oauthConsumerKey     = key
-                          , oauthConsumerSecret  = secret
-                          , oauthVersion         = OAuth10a
-                          })
-                (mkExtractCreds "twitter" idName)
-
--- | 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
+authTwitter :: YesodAuth m =>
+               String -- ^ Consumer Key
+            -> String -- ^ 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"
+authTwitter = authOAuth "twitter"
+                        "screen_name"
+                        "http://twitter.com/oauth/request_token"
+                        "http://twitter.com/oauth/access_token"
+                        "http://twitter.com/oauth/authorize"
 
 twitterUrl :: AuthRoute
 twitterUrl = oauthUrl "twitter"
 
-authTumblr :: YesodAuth m
-            => ByteString -- ^ Consumer Key
-            -> ByteString -- ^ Consumer Secret
-            -> AuthPlugin m
-authTumblr key secret = authOAuth
-                (newOAuth { oauthServerName      = "tumblr"
-                          , oauthRequestUri      = "http://www.tumblr.com/oauth/request_token"
-                          , oauthAccessTokenUri  = "http://www.tumblr.com/oauth/access_token"
-                          , oauthAuthorizeUri    = "http://www.tumblr.com/oauth/authorize"
-                          , oauthSignatureMethod = HMACSHA1
-                          , oauthConsumerKey     = key
-                          , oauthConsumerSecret  = secret
-                          , oauthVersion         = OAuth10a
-                          })
-                (mkExtractCreds "tumblr" "name")
-
-tumblrUrl :: AuthRoute
-tumblrUrl = oauthUrl "tumblr"
-
 bsToText :: ByteString -> Text
 bsToText = decodeUtf8With lenientDecode

yesod-auth-oauth/include/qq.h

@@ -0,0 +1,10 @@
+
+-- CPP macro which choses which quasyquotes syntax to use depending
+-- on GHC version.
+--
+-- QQ stands for quasyquote.
+#if GHC7
+# define QQ(x) x
+#else
+# define QQ(x) $x
+#endif

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

@@ -1,30 +1,37 @@
-cabal-version:   >= 1.10
 name:            yesod-auth-oauth
-version:         1.6.1
+version:         0.8.0
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
-maintainer:      Michael Litchard
+maintainer:      Hiromi Ishii
 synopsis:        OAuth Authentication for Yesod.
 category:        Web, Yesod
 stability:       Stable
+cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
-description:     API docs and the README are available at <http://www.stackage.org/package/yesod-auth-oauth>
-extra-source-files: README.md ChangeLog.md
+extra-source-files: include/qq.h
+description:     Authentication for Yesod.
+
+flag ghc7
 
 library
-    default-language: Haskell2010
-    build-depends:   authenticate-oauth      >= 1.5       && < 1.8
-                   , base                    >= 4.10      && < 5
-                   , bytestring              >= 0.9.1.4
-                   , text                    >= 0.7
-                   , unliftio
-                   , yesod-auth              >= 1.6       && < 1.7
-                   , yesod-core              >= 1.6       && < 1.7
-                   , yesod-form              >= 1.6       && < 1.8
+    if flag(ghc7)
+        build-depends:   base                >= 4.3      && < 5
+        cpp-options:     -DGHC7
+    else
+        build-depends:   base                >= 4        && < 4.3
+    build-depends:   authenticate-oauth      >= 1.0       && < 1.1
+                   , bytestring              >= 0.9.1.4   && < 0.10
+                   , yesod-core              >= 0.10      && < 0.11
+                   , yesod-auth              >= 0.8       && < 0.9
+                   , text                    >= 0.7       && < 0.12
+                   , hamlet                  >= 0.10      && < 0.11
+                   , yesod-form              >= 0.4       && < 0.5
+
     exposed-modules: Yesod.Auth.OAuth
     ghc-options:     -Wall
+    include-dirs: include
 
 source-repository head
   type:     git

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/LICENSE

@@ -1,20 +1,25 @@
-Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
 
-Permission is hereby granted, free of charge, to any person obtaining
-a copy of this software and associated documentation files (the
-"Software"), to deal in the Software without restriction, including
-without limitation the rights to use, copy, modify, merge, publish,
-distribute, sublicense, and/or sell copies of the Software, and to
-permit persons to whom the Software is furnished to do so, subject to
-the following conditions:
+Copyright 2010, Michael Snoyman. All rights reserved.
 
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
 
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

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,14 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Yesod.Auth
     ( -- * Subsite
@@ -18,433 +15,161 @@ module Yesod.Auth
     , AuthPlugin (..)
     , getAuth
     , YesodAuth (..)
-    , YesodAuthPersist (..)
       -- * Plugin interface
     , Creds (..)
     , setCreds
-    , setCredsRedirect
-    , clearCreds
-    , loginErrorMessage
-    , loginErrorMessageI
       -- * User functions
-    , AuthenticationResult (..)
-    , defaultMaybeAuthId
-    , defaultLoginHandler
-    , maybeAuthPair
+    , maybeAuthId
     , maybeAuth
     , requireAuthId
-    , requireAuthPair
     , requireAuth
       -- * Exception
     , AuthException (..)
-      -- * Helper
-    , MonadAuthHandler
-    , AuthHandler
-      -- * Internal
-    , credsKey
-    , provideJsonMessage
-    , messageJson401
-    , asHtml
     ) where
 
-import Control.Monad                 (when)
-import Control.Monad.Trans.Maybe
-import UnliftIO                      (withRunInIO, MonadUnliftIO)
+#include "qq.h"
 
-import Yesod.Auth.Routes
+import Control.Monad                 (when)  
+import Control.Monad.Trans.Maybe
+
+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.Client.TLS (getGlobalManager)
+import Network.HTTP.Conduit (Manager)
+
+import Language.Haskell.TH.Syntax hiding (lift)
 
 import qualified Network.Wai as W
+import Text.Hamlet (shamlet)
 
 import Yesod.Core
 import Yesod.Persist
+import Yesod.Json
 import Yesod.Auth.Message (AuthMessage, defaultMessage)
 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 qualified Control.Monad.Trans.Writer    as Writer
-import Control.Monad (void)
-import Data.Kind (Type)
+
+data Auth = Auth
 
 type AuthRoute = Route Auth
 
-type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
-type AuthHandler master a = forall m. MonadAuthHandler master m => m a
-
 type Method = Text
 type Piece = Text
 
--- | 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
+data AuthPlugin m = AuthPlugin
     { apName :: Text
-    , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
-    , apLogin :: (Route Auth -> Route master) -> WidgetFor master ()
+    , apDispatch :: Method -> [Piece] -> GHandler Auth m ()
+    , apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m ()
     }
 
 getAuth :: a -> Auth
 getAuth = const Auth
 
 -- | User credentials
-data Creds master = Creds
+data Creds m = 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 = liftHandler . defaultLayout
+class (Yesod m, PathPiece (AuthId m), RenderMessage m FormMessage) => YesodAuth m where
+    type AuthId m
 
     -- | Default destination on successful login, if no other
     -- destination exists.
-    loginDest :: master -> Route master
+    loginDest :: m -> Route m
 
     -- | Default destination on successful logout, if no other
     -- 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
+    logoutDest :: m -> Route m
 
     -- | Determine the ID associated with the set of credentials.
-    --
-    -- 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
+    getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))
 
     -- | Which authentication backends to use.
-    authPlugins :: master -> [AuthPlugin master]
+    authPlugins :: m -> [AuthPlugin m]
 
     -- | 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 :: GHandler Auth m RepHtml
+    loginHandler = defaultLayout $ do
+        setTitleI Msg.LoginTitle
+        tm <- lift getRouteToMaster
+        master <- lift getYesod
+        mapM_ (flip apLogin tm) (authPlugins master)
 
     -- | Used for i18n of messages provided by this package.
-    renderAuthMessage :: master
+    renderAuthMessage :: m
                       -> [Text] -- ^ languages
-                      -> AuthMessage
-                      -> Text
+                      -> AuthMessage -> Text
     renderAuthMessage _ _ = defaultMessage
 
     -- | After login and logout, redirect to the referring page, instead of
     -- 'loginDest' and 'logoutDest'. Default is 'False'.
-    redirectToReferer :: master -> Bool
+    redirectToReferer :: m -> 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 = liftIO getGlobalManager
+    -- @error \"authHttpManager"@ here.
+    authHttpManager :: m -> Manager
 
     -- | Called on a successful login. By default, calls
-    -- @addMessageI "success" NowLoggedIn@.
-    onLogin :: (MonadHandler m, master ~ HandlerSite m) => m ()
-    onLogin = addMessageI "success" Msg.NowLoggedIn
+    -- @setMessageI NowLoggedIn@.
+    onLogin :: GHandler s m ()
+    onLogin = setMessageI Msg.NowLoggedIn
 
     -- | Called on logout. By default, does nothing
-    onLogout :: (MonadHandler m, master ~ HandlerSite m) => m ()
+    onLogout :: GHandler s m ()
     onLogout = return ()
 
-    -- | Retrieves user credentials, if user is authenticated.
-    --
-    -- By default, this calls 'defaultMaybeAuthId' to get the user ID from the
-    -- session. This can be overridden to allow authentication via other means,
-    -- such as checking for a special token in a request header. This is
-    -- especially useful for creating an API to be accessed via some means
-    -- other than a browser.
-    --
-    -- @since 1.2.0
-    maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master))
+mkYesodSub "Auth"
+    [ ClassP ''YesodAuth [VarT $ mkName "master"]
+    ]
+#define STRINGS *Texts
+    [QQ(parseRoutes)|
+/check                 CheckR      GET
+/login                 LoginR      GET
+/logout                LogoutR     GET POST
+/page/#Text/STRINGS PluginR
+|]
 
-    default maybeAuthId
-        :: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master))
-        => m (Maybe (AuthId master))
-    maybeAuthId = defaultMaybeAuthId
-
-    -- | Called on login error for HTTP requests. By default, calls
-    -- @addMessage@ with "error" as status and redirects to @dest@.
-    onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html
-    onErrorHtml dest msg = do
-        addMessage "error" $ 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
 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
--- does a database request to make sure that the account is still in the database.
---
--- @since 1.1.2
-defaultMaybeAuthId
-    :: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master))
-    => m (Maybe (AuthId master))
-defaultMaybeAuthId = runMaybeT $ do
-    s   <- MaybeT $ lookupSession credsKey
-    aid <- MaybeT $ return $ fromPathPiece s
-    _   <- MaybeT $ cachedAuth aid
-    return aid
-
-cachedAuth
-    :: ( MonadHandler m
-       , YesodAuthPersist master
-       , Typeable (AuthEntity master)
-       , HandlerSite m ~ master
-       )
-    => AuthId master
-    -> m (Maybe (AuthEntity master))
-cachedAuth
-    = fmap unCachedMaybeAuth
-    . cached
-    . fmap CachedMaybeAuth
-    . getAuthEntity
-
-
--- | Default handler to show the login page.
---
--- This is the default 'loginHandler'.  It concatenates plugin widgets and
--- wraps the result in 'authLayout'.  See 'loginHandler' for more details.
---
--- @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
-
-
-loginErrorMessageMasterI
-  :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)
-  => Route master
-  -> AuthMessage
-  -> 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
-         :: (MonadHandler m, YesodAuth (HandlerSite m))
-         => Route (HandlerSite m)
-         -> Text
-         -> m TypedContent
-loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
-
-messageJson401
-  :: MonadHandler m
-  => 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
-        return obj
-
-provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
-provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
-
-
-setCredsRedirect
-  :: (MonadHandler m, YesodAuth (HandlerSite m))
-  => Creds (HandlerSite m) -- ^ new credentials
-  -> m TypedContent
-setCredsRedirect creds = do
+-- | FIXME: won't show up till redirect
+setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m ()
+setCreds doRedirects creds = do
     y    <- getYesod
-    auth <- authenticate creds
-    case auth of
-        Authenticated aid -> do
+    maid <- getAuthId creds
+    case maid of
+        Nothing ->
+          when doRedirects $ do
+            case authRoute y of
+              Nothing -> do rh <- defaultLayout $ addHtml [QQ(shamlet)| <h1>Invalid login |]
+                            sendResponse rh
+              Just ar -> do setMessageI Msg.InvalidLogin
+                            redirect ar
+        Just aid -> do
             setSession credsKey $ toPathPiece aid
-            onLogin
-            res <- selectRep $ do
-                provideRepType typeHtml $
-                    fmap asHtml $ redirectUltDest $ loginDest y
-                provideJsonMessage "Login Successful"
-            sendResponse res
+            when doRedirects $ do
+              onLogin
+              redirectUltDest $ loginDest y
 
-        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))
-         => Bool                  -- ^ if HTTP redirects should be done
-         -> Creds (HandlerSite m) -- ^ new credentials
-         -> m ()
-setCreds doRedirects creds =
-    if doRedirects
-      then void $ setCredsRedirect creds
-      else do auth <- authenticate creds
-              case auth of
-                  Authenticated aid -> setSession credsKey $ toPathPiece aid
-                  _ -> return ()
-
--- | same as defaultLayoutJson, but uses authLayout
-authLayoutJson
-  :: (ToJSON j, MonadAuthHandler master m)
-  => WidgetFor master ()  -- ^ HTML
-  -> m j  -- ^ JSON
-  -> 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
-clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
-           => Bool -- ^ if HTTP, redirect to 'logoutDest'
-           -> m ()
-clearCreds doRedirects = do
-    onLogout
-    deleteSession credsKey
-    y  <- getYesod
-    aj <- acceptsJson
-    case (aj, doRedirects) of
-      (True, _)               -> sendResponse successfulLogout
-      (False, True)           -> redirectUltDest (logoutDest y)
-      _                       -> return ()
-    where successfulLogout = object ["message" .= msg]
-          msg :: Text
-          msg = "Logged out successfully!"
-
-getCheckR :: AuthHandler master TypedContent
+getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson
 getCheckR = do
     creds <- maybeAuthId
-    authLayoutJson (do
+    defaultLayoutJson (do
         setTitle "Authentication Status"
-        toWidget $ html' creds) (return $ jsonCreds creds)
+        addHtml $ html' creds) (jsonCreds creds)
   where
     html' creds =
-        [shamlet|
-$newline never
+        [QQ(shamlet)|
 <h1>Authentication Status
 $maybe _ <- creds
     <p>Logged in.
@@ -452,27 +177,29 @@ $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' :: YesodAuth master => GHandler sub master ()
 setUltDestReferer' = do
-    master <- getYesod
-    when (redirectToReferer master) setUltDestReferer
+    m <- getYesod
+    when (redirectToReferer m) setUltDestReferer
 
-getLoginR :: AuthHandler master Html
+getLoginR :: YesodAuth m => GHandler Auth m RepHtml
 getLoginR = setUltDestReferer' >> loginHandler
 
-getLogoutR :: AuthHandler master ()
-getLogoutR = do
-  tp <- getRouteToParent
-  setUltDestReferer' >> redirectToPost (tp LogoutR)
+getLogoutR :: YesodAuth m => GHandler Auth m ()
+getLogoutR = setUltDestReferer' >> postLogoutR -- FIXME redirect to post
 
-postLogoutR :: AuthHandler master ()
-postLogoutR = clearCreds True
+postLogoutR :: YesodAuth m => GHandler Auth m ()
+postLogoutR = do
+    y <- getYesod
+    deleteSession credsKey
+    onLogout
+    redirectUltDest $ logoutDest y
 
-handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
+handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m ()
 handlePluginR plugin pieces = do
     master <- getYesod
     env <- waiRequest
@@ -481,135 +208,52 @@ handlePluginR plugin pieces = do
         [] -> notFound
         ap:_ -> apDispatch ap method pieces
 
--- | Similar to 'maybeAuthId', but additionally look up the value associated
--- 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
-maybeAuth :: ( YesodAuthPersist master
-             , val ~ AuthEntity master
-             , Key val ~ AuthId master
+-- | Retrieves user credentials, if user is authenticated.
+maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))
+maybeAuthId = do
+    ms <- lookupSession credsKey
+    case ms of
+        Nothing -> return Nothing
+        Just s -> return $ fromPathPiece s
+
+maybeAuth :: ( YesodAuth m
+             , b ~ YesodPersistBackend m
+             , b ~ PersistEntityBackend val
+             , Key b val ~ AuthId m
+             , PersistStore b (GHandler s m)
              , PersistEntity val
-             , Typeable val
-             , MonadHandler m
-             , HandlerSite m ~ master
-             ) => m (Maybe (Entity val))
-maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
+             , YesodPersist m
+             ) => GHandler s m (Maybe (Entity val))
+maybeAuth = runMaybeT $ do
+    aid <- MaybeT $ maybeAuthId
+    a   <- MaybeT $ runDB $ get aid
+    return $ Entity aid a
 
--- | 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
-    return (aid, ae)
+requireAuthId :: YesodAuth m => GHandler s m (AuthId m)
+requireAuthId = maybeAuthId >>= maybe redirectLogin return
 
-
-newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
-
--- | Class which states that the given site is an instance of @YesodAuth@
--- and that its @AuthId@ is a lookup key for the full user information in
--- a @YesodPersist@ database.
---
--- The default implementation of @getAuthEntity@ assumes that the @AuthId@
--- for the @YesodAuth@ superclass is in fact a persistent @Key@ for the
--- given value.  This is the common case in Yesod, and means that you can
--- easily look up the full information on a given user.
---
--- @since 1.4.0
-class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
-    -- | If the @AuthId@ for a given site is a persistent ID, this will give the
-    -- value for that entity. E.g.:
-    --
-    -- > 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).
---
--- @since 1.1.0
-requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m))
-requireAuthId = maybeAuthId >>= maybe handleAuthLack return
-
--- | Similar to 'maybeAuth', but redirects to a login page if user is not
--- authenticated or responds with error 401 if this is an API client (expecting JSON).
---
--- @since 1.1.0
-requireAuth :: ( YesodAuthPersist master
-               , val ~ AuthEntity master
-               , Key val ~ AuthId master
+requireAuth :: ( YesodAuth m
+               , b ~ YesodPersistBackend m
+               , b ~ PersistEntityBackend val
+               , Key b val ~ AuthId m
+               , PersistStore b (GHandler s m)
                , PersistEntity val
-               , Typeable val
-               , MonadHandler m
-               , HandlerSite m ~ master
-               ) => m (Entity val)
-requireAuth = maybeAuth >>= maybe handleAuthLack return
+               , YesodPersist m
+               ) => GHandler s m (Entity val)
+requireAuth = maybeAuth >>= maybe redirectLogin return
 
--- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
--- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple.
---
--- @since 1.4.0
-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 :: Yesod m => GHandler s m a
 redirectLogin = do
     y <- getYesod
-    when (redirectToCurrent y) setUltDestCurrent
+    setUltDestCurrent
     case authRoute y of
         Just z -> redirect z
         Nothing -> permissionDenied "Please configure authRoute"
 
-instance YesodAuth master => RenderMessage master AuthMessage where
+instance YesodAuth m => RenderMessage m AuthMessage where
     renderMessage = renderAuthMessage
 
-data AuthException = InvalidFacebookResponse
-    deriving Show
+data AuthException = InvalidBrowserIDAssertion
+                   | InvalidFacebookResponse
+    deriving (Show, Typeable)
 instance Exception AuthException
-
-instance YesodAuth master => YesodSubDispatch Auth master where
-    yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
-
-asHtml :: Html -> Html
-asHtml = id

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -1,170 +1,74 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
 {-# 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
+    , authBrowserIdAudience
     ) 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 Network.URI (uriPath, parseURI)
-import Data.FileEmbed (embedFile)
-import Data.ByteString (ByteString)
-import Data.Default
+import Control.Monad.IO.Class (liftIO)
+import Control.Exception (throwIO)
+
+#include "qq.h"
 
 pid :: Text
 pid = "browserid"
 
-forwardUrl :: AuthRoute
-forwardUrl = PluginR pid []
+complete :: Route Auth
+complete = PluginR pid []
 
-complete :: AuthRoute
-complete = forwardUrl
+-- | Log into browser ID with an audience value determined from the 'approot'.
+authBrowserId :: YesodAuth m => AuthPlugin m
+authBrowserId = helper Nothing
 
--- | A settings type for various configuration options relevant to BrowserID.
---
--- See: <http://www.yesodweb.com/book/settings-types>
---
--- Since 1.2.0
-data BrowserIdSettings = BrowserIdSettings
-    { bisAudience :: Maybe Text
-    -- ^ BrowserID audience value. If @Nothing@, will be extracted based on the
-    -- approot.
-    --
-    -- Default: @Nothing@
-    --
-    -- Since 1.2.0
-    , bisLazyLoad :: Bool
-    -- ^ Use asynchronous Javascript loading for the BrowserID JS file.
-    --
-    -- Default: @True@.
-    --
-    -- Since 1.2.0
-    }
+-- | Log into browser ID with the given audience value. Note that this must be
+-- your actual hostname, or login will fail.
+authBrowserIdAudience
+    :: YesodAuth m
+    => Text -- ^ audience
+    -> AuthPlugin m
+authBrowserIdAudience = helper . Just
 
-instance Default BrowserIdSettings where
-    def = BrowserIdSettings
-        { bisAudience = Nothing
-        , bisLazyLoad = True
-        }
-
-authBrowserId :: YesodAuth m => BrowserIdSettings -> AuthPlugin m
-authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
+helper :: YesodAuth m
+       => Maybe Text -- ^ audience
+       -> AuthPlugin m
+helper maudience = AuthPlugin
     { apName = pid
     , apDispatch = \m ps ->
         case (m, ps) of
             ("GET", [assertion]) -> do
+                master <- getYesod
                 audience <-
-                    case bisAudience of
+                    case maudience of
                         Just a -> return a
                         Nothing -> do
+                            tm <- getRouteToMaster
                             r <- getUrlRender
-                            tm <- getRouteToParent
                             return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
-                manager <- authHttpManager
-                memail <- checkAssertion audience assertion manager
+                memail <- lift $ checkAssertion audience assertion (authHttpManager master)
                 case memail of
-                    Nothing -> do
-                      $logErrorS "yesod-auth" "BrowserID assertion failure"
-                      tm <- getRouteToParent
-                      loginErrorMessage (tm LoginR) "BrowserID login error."
-                    Just email -> setCredsRedirect Creds
+                    Nothing -> liftIO $ throwIO InvalidBrowserIDAssertion
+                    Just email -> setCreds True Creds
                         { credsPlugin = pid
                         , credsIdent = email
                         , credsExtra = []
                         }
-            ("GET", ["static", "sign-in.png"]) -> sendResponse
-                ( "image/png" :: ByteString
-                , toContent $(embedFile "persona_sign_in_blue.png")
-                )
             (_, []) -> badMethod
             _ -> notFound
     , apLogin = \toMaster -> do
-        onclick <- createOnClick bis toMaster
-
-        autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
-        when autologin $ toWidget [julius|#{rawJS onclick}();|]
-
-        toWidget [hamlet|
-$newline never
+        addScriptRemote browserIdJs
+        addHamlet [QQ(hamlet)|
 <p>
-    <a href="javascript:#{onclick}()">
-        <img src=@{toMaster loginIcon}>
+    <a href="javascript:navigator.id.getVerifiedEmail(function(a){if(a)document.location='@{toMaster complete}/'+a});">
+        <img src="https://browserid.org/i/sign_in_green.png">
 |]
     }
   where
-    loginIcon = PluginR pid ["static", "sign-in.png"]
     stripScheme t = fromMaybe t $ T.stripPrefix "//" $ snd $ T.breakOn "//" t
-
--- | Generates a function to handle on-click events, and returns that function
--- name.
-createOnClickOverride :: BrowserIdSettings
-              -> (Route Auth -> Route master)
-              -> Maybe (Route master)
-              -> WidgetFor master Text
-createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
-    unless bisLazyLoad $ addScriptRemote browserIdJs
-    onclick <- newIdent
-    render <- getUrlRender
-    let login = toJSON $ getPath $ render loginRoute -- (toMaster LoginR)
-        loginRoute = maybe (toMaster LoginR) id mOnRegistration
-    toWidget [julius|
-        function #{rawJS onclick}() {
-            if (navigator.id) {
-                navigator.id.watch({
-                    onlogin: function (assertion) {
-                        if (assertion) {
-                            document.location = "@{toMaster complete}/" + assertion;
-                        }
-                    },
-                    onlogout: function () {}
-                });
-                navigator.id.request({
-                    returnTo: #{login} + "?autologin=true"
-                });
-            }
-            else {
-                alert("Loading, please try again");
-            }
-        }
-    |]
-    when bisLazyLoad $ toWidget [julius|
-        (function(){
-            var bid = document.createElement("script");
-            bid.async = true;
-            bid.src = #{toJSON browserIdJs};
-            var s = document.getElementsByTagName('script')[0];
-            s.parentNode.insertBefore(bid, s);
-        })();
-    |]
-
-    autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
-    when autologin $ toWidget [julius|#{rawJS onclick}();|]
-    return onclick
-  where
-    getPath t = fromMaybe t $ do
-        uri <- parseURI $ T.unpack t
-        return $ T.pack $ uriPath uri
-
--- | Generates a function to handle on-click events, and returns that function
--- name.
-createOnClick :: BrowserIdSettings
-              -> (Route Auth -> Route master)
-              -> WidgetFor master Text
-createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing

yesod-auth/Yesod/Auth/Dummy.hs

@@ -1,77 +1,34 @@
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 -- | Provides a dummy authentication module that simply lets a user specify
--- their identifier. This is not intended for real world use, just for
--- testing. This plugin supports form submissions via JSON (since 1.6.8).
---
--- = Using the JSON Login Endpoint
---
--- We are assuming that you have declared `authRoute` as follows
---
--- @
---       Just $ AuthR LoginR
--- @
---
--- If you are using a different one, then you have to adjust the
--- endpoint accordingly.
---
--- @
---       Endpoint: \/auth\/page\/dummy
---       Method: POST
---       JSON Data: {
---                      "ident": "my identifier"
---                  }
--- @
---
--- Remember to add the following headers:
---
---     - Accept: application\/json
---     - Content-Type: application\/json
-
+-- his/her identifier. This is not intended for real world use, just for
+-- testing.
 module Yesod.Auth.Dummy
     ( authDummy
     ) where
 
-import           Data.Aeson.Types (Parser, Result (..))
-import qualified Data.Aeson.Types as A (parseEither, withObject)
-import           Data.Text        (Text)
-import           Yesod.Auth
-import           Yesod.Core
-import           Yesod.Form       (ireq, runInputPost, textField)
+#include "qq.h"
 
-identParser :: Value -> Parser Text
-identParser = A.withObject "Ident" (.: "ident")
+import Yesod.Auth
+import Yesod.Form (runInputPost, textField, ireq)
+import Yesod.Handler (notFound)
+import Text.Hamlet (hamlet)
+import Yesod.Widget (addHamlet)
 
 authDummy :: YesodAuth m => AuthPlugin m
 authDummy =
     AuthPlugin "dummy" dispatch login
   where
-    dispatch :: Text -> [Text] -> AuthHandler m TypedContent
     dispatch "POST" [] = do
-        (jsonResult :: Result Value) <- parseCheckJsonBody
-        eIdent <- case jsonResult of
-            Success val -> return $ A.parseEither identParser val
-            Error   err -> return $ Left err
-        case eIdent of
-            Right ident ->
-                setCredsRedirect $ Creds "dummy" ident []
-            Left  _     -> do
-                ident <- runInputPost $ ireq textField "ident"
-                setCredsRedirect $ Creds "dummy" ident []
+        ident <- runInputPost $ ireq textField "ident"
+        setCreds True $ Creds "dummy" ident []
     dispatch _ _ = notFound
     url = PluginR "dummy" []
-    login authToMaster = do
-        request <- getRequest
-        toWidget [hamlet|
-$newline never
+    login authToMaster =
+        addHamlet [QQ(hamlet)|
 <form method="post" action="@{authToMaster url}">
-    $maybe t <- reqToken request
-        <input type=hidden name=#{defaultCsrfParamName} value=#{t}>
-    Your new identifier is: #
+    \Your new identifier is: 
     <input type="text" name="ident">
     <input type="submit" value="Dummy Login">
 |]

yesod-auth/Yesod/Auth/GoogleEmail.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | 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.Form
+import Yesod.Handler
+import Yesod.Widget
+import Yesod.Request
+import Text.Blaze (toHtml)
+import Data.Text (Text)
+import qualified Yesod.Auth.Message as Msg
+import qualified Data.Text as T
+import Control.Exception.Lifted (try, SomeException)
+
+forwardUrl :: AuthRoute
+forwardUrl = PluginR "googleemail" ["forward"]
+
+authGoogleEmail :: YesodAuth m => AuthPlugin m
+authGoogleEmail =
+    AuthPlugin "googleemail" dispatch login
+  where
+    complete = PluginR "googleemail" ["complete"]
+    name = "openid_identifier"
+    login tm = do
+        [whamlet|
+<form method=get action=@{tm forwardUrl}>
+    <input type=hidden name=openid_identifier value=https://www.google.com/accounts/o8/id>
+    <input type=submit value=_{Msg.LoginGoogle}>
+|]
+    dispatch "GET" ["forward"] = do
+        roid <- runInputGet $ iopt textField name
+        case roid of
+            Just oid -> do
+                render <- getUrlRender
+                toMaster <- getRouteToMaster
+                let complete' = render $ toMaster complete
+                master <- getYesod
+                eres <- lift $ try $ OpenId.getForwardUrl oid 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
+                        setMessage $ toHtml $ show (err :: SomeException)
+                        redirect $ toMaster LoginR
+                        )
+                  redirect
+                  eres
+            Nothing -> do
+                toMaster <- getRouteToMaster
+                setMessageI Msg.NoOpenID
+                redirect $ toMaster LoginR
+    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 m => [(Text, Text)] -> GHandler Auth m ()
+completeHelper gets' = do
+        master <- getYesod
+        eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master)
+        toMaster <- getRouteToMaster
+        let onFailure err = do
+            setMessage $ toHtml $ show (err :: SomeException)
+            redirect $ toMaster LoginR
+        let onSuccess (OpenId.Identifier ident, _) = do
+                memail <- lookupGetParam "openid.ext1.value.email"
+                case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
+                    (Just email, True) -> setCreds True $ Creds "openid" email []
+                    (_, False) -> do
+                        setMessage "Only Google login is supported"
+                        redirect $ toMaster LoginR
+                    (Nothing, _) -> do
+                        setMessage "No email address provided"
+                        redirect $ toMaster LoginR
+        either onFailure onSuccess eres

yesod-auth/Yesod/Auth/GoogleEmail2.hs

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

yesod-auth/Yesod/Auth/Hardcoded.hs

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

@@ -0,0 +1,277 @@
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE GADTs                      #-}
+-------------------------------------------------------------------------------
+-- |
+-- Module      :  Yesod.Auth.HashDB
+-- Copyright   :  (c) Patrick Brisbin 2010 
+-- License     :  as-is
+--
+-- Maintainer  :  pbrisbin@gmail.com
+-- Stability   :  Stable
+-- Portability :  Portable
+--
+-- A yesod-auth AuthPlugin designed to look users up in Persist where
+-- their user id's and a salted SHA1 hash of their password is stored.
+--
+-- Example usage:
+--
+-- > -- import the function
+-- > import Auth.HashDB
+-- >
+-- > -- make sure you have an auth route
+-- > mkYesodData "MyApp" [$parseRoutes|
+-- > / RootR GET
+-- > /auth AuthR Auth getAuth
+-- > |]
+-- >
+-- >
+-- > -- make your app an instance of YesodAuth using this plugin
+-- > instance YesodAuth MyApp where
+-- >    type AuthId MyApp = UserId
+-- >
+-- >    loginDest _  = RootR
+-- >    logoutDest _ = RootR
+-- >    getAuthId    = getAuthIdHashDB AuthR (Just . UniqueUser)
+-- >    authPlugins  = [authHashDB (Just . UniqueUser)]
+-- >
+-- >
+-- > -- include the migration function in site startup
+-- > withServer :: (Application -> IO a) -> IO a
+-- > withServer f = withConnectionPool $ \p -> do
+-- >     runSqlPool (runMigration migrateUsers) p
+-- >     let h = DevSite p
+--
+-- Note that function which converts username to unique identifier must be same.
+--
+-- Your app must be an instance of YesodPersist. and the username,
+-- salt and hashed-passwords should be added to the database.
+--
+-- > echo -n 'MySaltMyPassword' | sha1sum
+--
+-- can be used to get the hash from the commandline.
+--
+-------------------------------------------------------------------------------
+module Yesod.Auth.HashDB
+    ( HashDBUser(..)
+    , Unique (..)
+    , setPassword
+      -- * Authentification
+    , validateUser
+    , authHashDB
+    , getAuthIdHashDB
+      -- * Predefined data type
+    , User
+    , UserGeneric (..)
+    , UserId
+    , migrateUsers
+    ) where
+
+#include "qq.h"
+
+import Yesod.Persist
+import Yesod.Handler
+import Yesod.Form
+import Yesod.Auth
+import Yesod.Widget (addHamlet)
+import Text.Hamlet (hamlet, shamlet)
+
+import Control.Applicative         ((<$>), (<*>))
+import Control.Monad               (replicateM,liftM)
+import Control.Monad.IO.Class      (MonadIO, liftIO)
+
+import qualified Data.ByteString.Lazy.Char8 as BS (pack)
+import Data.Digest.Pure.SHA        (sha1, showDigest)
+import Data.Text                   (Text, pack, unpack, append)
+import Data.Maybe                  (fromMaybe)
+import System.Random               (randomRIO)
+
+-- | Interface for data type which holds user info. It's just a
+--   collection of getters and setters
+class HashDBUser user where
+  -- | Retrieve password hash from user data
+  userPasswordHash :: user -> Maybe Text
+  -- | Retrieve salt for password
+  userPasswordSalt :: user -> Maybe Text
+
+  -- | Deprecated for the better named setSaltAndPasswordHash 
+  setUserHashAndSalt :: Text    -- ^ Salt
+                     -> Text    -- ^ Password hash
+                     -> user -> user
+  setUserHashAndSalt = setSaltAndPasswordHash
+
+  -- | a callback for setPassword
+  setSaltAndPasswordHash :: Text    -- ^ Salt
+                     -> Text    -- ^ Password hash
+                     -> user -> user
+  setSaltAndPasswordHash = setUserHashAndSalt
+
+-- | Generate random salt. Length of 8 is chosen arbitrarily
+randomSalt :: MonadIO m => m Text
+randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z')))
+
+-- | Calculate salted hash using SHA1.
+saltedHash :: Text              -- ^ Salt
+           -> Text              -- ^ Password
+           -> Text
+saltedHash salt = 
+  pack . showDigest . sha1 . BS.pack . unpack . append salt
+
+-- | Set password for user. This function should be used for setting
+--   passwords. It generates random salt and calculates proper hashes.
+setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user
+setPassword pwd u = do salt <- randomSalt
+                       return $ setSaltAndPasswordHash salt (saltedHash salt pwd) u
+
+
+----------------------------------------------------------------
+-- Authentification
+----------------------------------------------------------------
+
+-- | Given a user ID and password in plaintext, validate them against
+--   the database values.
+validateUser :: ( YesodPersist yesod
+                , b ~ YesodPersistBackend yesod
+                , b ~ PersistEntityBackend user
+                , PersistStore b (GHandler sub yesod)
+                , PersistUnique b (GHandler sub yesod)
+                , PersistEntity user
+                , HashDBUser    user
+                ) => 
+                Unique user b   -- ^ User unique identifier
+             -> Text            -- ^ Password in plaint-text
+             -> GHandler sub yesod Bool
+validateUser userID passwd = do
+  -- Checks that hash and password match
+  let validate u = do hash <- userPasswordHash u
+                      salt <- userPasswordSalt u
+                      return $ hash == saltedHash salt passwd
+  -- Get user data
+  user <- runDB $ getBy userID
+  return $ fromMaybe False $ validate . entityVal =<< user
+
+
+login :: AuthRoute
+login = PluginR "hashdb" ["login"]
+
+
+-- | Handle the login form. First parameter is function which maps
+--   username (whatever it might be) to unique user ID.
+postLoginR :: ( YesodAuth y, YesodPersist y
+              , b ~ YesodPersistBackend y
+              , b ~ PersistEntityBackend user
+              , HashDBUser user, PersistEntity user
+              , PersistStore b (GHandler Auth y)
+              , PersistUnique b (GHandler Auth y))
+           => (Text -> Maybe (Unique user b)) 
+           -> GHandler Auth y ()
+postLoginR uniq = do
+    (mu,mp) <- runInputPost $ (,)
+        <$> iopt textField "username"
+        <*> iopt textField "password"
+
+    isValid <- fromMaybe (return False) 
+                 (validateUser <$> (uniq =<< mu) <*> mp)
+    if isValid 
+       then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
+       else do setMessage [QQ(shamlet)| Invalid username/password |]
+               toMaster <- getRouteToMaster
+               redirect $ toMaster LoginR
+
+
+-- | A drop in for the getAuthId method of your YesodAuth instance which
+--   can be used if authHashDB is the only plugin in use.
+getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
+                   , HashDBUser user, PersistEntity user
+                   , Key b user ~ AuthId master
+                   , b ~ YesodPersistBackend master
+                   , b ~ PersistEntityBackend user
+                   , PersistUnique b (GHandler sub master)
+                   , PersistStore b (GHandler sub master))
+                => (AuthRoute -> Route master)   -- ^ your site's Auth Route
+                -> (Text -> Maybe (Unique user b)) -- ^ gets user ID
+                -> Creds master                  -- ^ the creds argument
+                -> GHandler sub master (Maybe (AuthId master))
+getAuthIdHashDB authR uniq creds = do
+    muid <- maybeAuthId
+    case muid of
+        -- user already authenticated
+        Just uid -> return $ Just uid
+        Nothing       -> do
+            x <- case uniq (credsIdent creds) of
+                   Nothing -> return Nothing
+                   Just u  -> runDB (getBy u)
+            case x of
+                -- user exists
+                Just (Entity uid _) -> return $ Just uid
+                Nothing       -> do
+                    setMessage [QQ(shamlet)| User not found |]
+                    redirect $ authR LoginR
+
+-- | Prompt for username and password, validate that against a database
+--   which holds the username and a hash of the password
+authHashDB :: ( YesodAuth m, YesodPersist m
+              , HashDBUser user
+              , PersistEntity user
+              , b ~ YesodPersistBackend m
+              , b ~ PersistEntityBackend user
+              , PersistStore b (GHandler Auth m)
+              , PersistUnique b (GHandler Auth m))
+           => (Text -> Maybe (Unique user b)) -> AuthPlugin m
+authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet
+    [QQ(hamlet)|
+    <div id="header">
+        <h1>Login
+
+    <div id="login">
+        <form method="post" action="@{tm login}">
+            <table>
+                <tr>
+                    <th>Username:
+                    <td>
+                        <input id="x" name="username" autofocus="" required>
+                <tr>
+                    <th>Password:
+                    <td>
+                        <input type="password" name="password" required>
+                <tr>
+                    <td>&nbsp;
+                    <td>
+                        <input type="submit" value="Login">
+
+            <script>
+                if (!("autofocus" in document.createElement("input"))) {
+                    document.getElementById("x").focus();
+                }
+
+|]
+    where
+        dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
+        dispatch _ _              = notFound
+
+
+----------------------------------------------------------------
+-- Predefined datatype
+----------------------------------------------------------------
+
+-- | Generate data base instances for a valid user
+share [mkPersist sqlSettings, mkMigrate "migrateUsers"]
+         [QQ(persistUpperCase)|
+User
+    username Text Eq
+    password Text
+    salt     Text
+    UniqueUser username
+|]
+
+instance HashDBUser (UserGeneric backend) where
+  userPasswordHash = Just . userPassword
+  userPasswordSalt = Just . userSalt
+  setSaltAndPasswordHash s h u = u { userSalt     = s
+                               , userPassword = h
+                               }

yesod-auth/Yesod/Auth/Message.hs

@@ -6,24 +6,10 @@ module Yesod.Auth.Message
       -- * All languages
     , englishMessage
     , portugueseMessage
-    , swedishMessage
-    , germanMessage
-    , frenchMessage
-    , norwegianBokmålMessage
-    , japaneseMessage
-    , finnishMessage
-    , chineseMessage
-    , croatianMessage
-    , spanishMessage
-    , czechMessage
-    , russianMessage
-    , dutchMessage
-    , danishMessage
-    , koreanMessage
     ) where
 
-import           Data.Monoid (mappend, (<>))
-import           Data.Text   (Text)
+import Data.Monoid (mappend)
+import Data.Text (Text)
 
 data AuthMessage =
       NoOpenID
@@ -31,8 +17,6 @@ data AuthMessage =
     | LoginGoogle
     | LoginYahoo
     | Email
-    | UserName
-    | IdentifierNotFound Text
     | Password
     | Register
     | RegisterLong
@@ -40,8 +24,6 @@ data AuthMessage =
     | ConfirmationEmailSentTitle
     | ConfirmationEmailSent Text
     | AddressVerified
-    | EmailVerifiedChangePass
-    | EmailVerified
     | InvalidKeyTitle
     | InvalidKey
     | InvalidEmailPass
@@ -59,19 +41,6 @@ data AuthMessage =
     | LoginTitle
     | PleaseProvideUsername
     | PleaseProvidePassword
-    | NoIdentifierProvided
-    | InvalidEmailAddress
-    | PasswordResetTitle
-    | 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 +48,20 @@ defaultMessage = englishMessage
 
 englishMessage :: AuthMessage -> Text
 englishMessage NoOpenID = "No OpenID identifier found"
-englishMessage LoginOpenID = "Log in via OpenID"
-englishMessage LoginGoogle = "Log in via Google"
-englishMessage LoginYahoo = "Log in via Yahoo"
+englishMessage LoginOpenID = "Login via OpenID"
+englishMessage LoginGoogle = "Login via Google"
+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 EmailVerifiedChangePass = "Email address verified, please set a new password"
-englishMessage EmailVerified = "Email address verified"
+englishMessage AddressVerified = "Address verified, please set a new password"
 englishMessage InvalidKeyTitle = "Invalid verification key"
 englishMessage InvalidKey = "I'm sorry, but that was an invalid verification key."
 englishMessage InvalidEmailPass = "Invalid email/password combination"
@@ -107,24 +72,13 @@ 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 LoginViaEmail = "Log in via email"
+englishMessage Facebook = "Login with Facebook"
+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"
-englishMessage InvalidEmailAddress = "Invalid email address provided"
-englishMessage PasswordResetTitle = "Password Reset"
-englishMessage ProvideIdentifier = "Email or Username"
-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 +86,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 +96,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"
@@ -163,706 +113,3 @@ portugueseMessage NowLoggedIn = "Você acaba de entrar no site com sucesso!"
 portugueseMessage LoginTitle = "Entrar no site"
 portugueseMessage PleaseProvideUsername = "Por favor digite seu nome de usuário"
 portugueseMessage PleaseProvidePassword = "Por favor digite sua senha"
-portugueseMessage NoIdentifierProvided = "Nenhum e-mail ou nome de usuário informado"
-portugueseMessage InvalidEmailAddress = "Endereço de e-mail inválido informado"
-portugueseMessage PasswordResetTitle = "Resetar senha"
-portugueseMessage ProvideIdentifier = "E-mail ou nome de usuário"
-portugueseMessage SendPasswordResetEmail = "Enviar e-mail para resetar senha"
-portugueseMessage PasswordResetPrompt = "Insira seu endereço de e-mail ou nome de usuário abaixo.  Um e-mail para resetar sua senha será enviado para você."
-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"
-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."
-spanishMessage ConfirmationEmailSentTitle = "La confirmación de correo ha sido enviada"
-spanishMessage (ConfirmationEmailSent email) =
-    "Una confirmación de correo electrónico ha sido enviada a " `mappend`
-    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"
-spanishMessage BadSetPass = "Debe acceder a la aplicación para modificar la contraseña"
-spanishMessage SetPassTitle = "Modificar contraseña"
-spanishMessage SetPass = "Actualizar nueva contraseña"
-spanishMessage NewPass = "Nueva contraseña"
-spanishMessage ConfirmPass = "Confirmar"
-spanishMessage PassMismatch = "Las contraseñas no coinciden, inténtelo de nuevo"
-spanishMessage PassUpdated = "Contraseña actualizada"
-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 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 ProvideIdentifier = "Cuenta de correo o nombre de usuario"
-spanishMessage SendPasswordResetEmail = "Enviar correo de actualización de contraseña"
-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"
-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."
-swedishMessage ConfirmationEmailSentTitle = "Konfirmationsmail skickat"
-swedishMessage (ConfirmationEmailSent email) =
-    "Ett konfirmationsmeddelande har skickats till" `mappend`
-    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"
-swedishMessage BadSetPass = "Du måste vara inloggad för att ange ett lösenord"
-swedishMessage SetPassTitle = "Ange lösenord"
-swedishMessage SetPass = "Ange nytt lösenord"
-swedishMessage NewPass = "Nytt lösenord"
-swedishMessage ConfirmPass = "Godkänn"
-swedishMessage PassMismatch = "Lösenorden matcha ej, vänligen försök igen"
-swedishMessage PassUpdated = "Lösenord updaterades"
-swedishMessage Facebook = "Logga in med Facebook"
-swedishMessage LoginViaEmail = "Logga in via epost"
-swedishMessage InvalidLogin = "Ogiltigt login"
-swedishMessage NowLoggedIn = "Du är nu inloggad"
-swedishMessage LoginTitle = "Logga in"
-swedishMessage PleaseProvideUsername = "Vänligen fyll i användarnamn"
-swedishMessage PleaseProvidePassword = "Vänligen fyll i lösenord"
-swedishMessage NoIdentifierProvided = "Emailadress eller användarnamn saknas"
-swedishMessage InvalidEmailAddress = "Ogiltig emailadress angiven"
-swedishMessage PasswordResetTitle = "Återställning av lösenord"
-swedishMessage ProvideIdentifier = "Epost eller användarnamn"
-swedishMessage SendPasswordResetEmail = "Skicka email för återställning av lösenord"
-swedishMessage PasswordResetPrompt = "Skriv in din emailadress eller användarnamn nedan och " `mappend`
-                                     "ett email för återställning av lösenord kommmer att skickas till dig."
-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 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 ConfirmationEmailSentTitle = "Bestätigung verschickt."
-germanMessage (ConfirmationEmailSent email) =
-    "Eine Bestätigung wurde an " `mappend`
-    email `mappend`
-    " versandt."
-germanMessage AddressVerified = "Adresse bestätigt, bitte neues Passwort angeben"
-germanMessage EmailVerifiedChangePass = "Adresse bestätigt, bitte neues Passwort angeben"
-germanMessage EmailVerified = "Adresse bestätigt"
-germanMessage InvalidKeyTitle = "Ungültiger Bestätigungsschlüssel"
-germanMessage InvalidKey = "Das war leider ein ungültiger Bestätigungsschlüssel"
-germanMessage InvalidEmailPass = "Ungültiger Nutzername oder Passwort"
-germanMessage BadSetPass = "Um das Passwort zu ändern muss man eingeloggt sein"
-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 PassUpdated = "Passwort überschrieben"
-germanMessage Facebook = "Login über Facebook"
-germanMessage LoginViaEmail = "Login via E-Mail"
-germanMessage InvalidLogin = "Ungültiger Login"
-germanMessage NowLoggedIn = "Login erfolgreich"
-germanMessage LoginTitle = "Anmelden"
-germanMessage PleaseProvideUsername = "Bitte Nutzername angeben"
-germanMessage PleaseProvidePassword = "Bitte Passwort angeben"
-germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben"
-germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter"
-germanMessage PasswordResetTitle = "Passwort zurücksetzen"
-germanMessage ProvideIdentifier = "E-Mail-Adresse oder Nutzername"
-germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen"
-germanMessage PasswordResetPrompt = "Nach Einhabe der E-Mail-Adresse oder des Nutzernamen wird eine E-Mail zugesendet mit welcher das Passwort zurückgesetzt werden kann."
-germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"
-germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO
-germanMessage Logout = "Abmelden"
-germanMessage LogoutTitle = "Abmelden"
-germanMessage AuthError = "Fehler beim Anmelden"
-
-frenchMessage :: AuthMessage -> Text
-frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"
-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é"
-frenchMessage ConfirmationEmailSentTitle = "Message de confirmation"
-frenchMessage (ConfirmationEmailSent email) =
-    "Un message de confirmation a été envoyé à " `mappend`
-    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 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"
-frenchMessage NewPass = "Nouveau mot de passe"
-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 InvalidLogin = "Nom d'utilisateur incorrect"
-frenchMessage NowLoggedIn = "Vous êtes maintenant connecté"
-frenchMessage LoginTitle = "Se connecter"
-frenchMessage PleaseProvideUsername = "Veuillez fournir votre nom d'utilisateur"
-frenchMessage PleaseProvidePassword = "Veuillez fournir votre 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 ProvideIdentifier = "Adresse électronique ou nom d'utilisateur"
-frenchMessage SendPasswordResetEmail = "Envoi d'un courriel pour réinitialiser 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 InvalidUsernamePass = "La combinaison de ce mot de passe et de ce nom d'utilisateur n'existe pas."
-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"
-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."
-norwegianBokmålMessage ConfirmationEmailSentTitle = "E-postkonfirmasjon sendt."
-norwegianBokmålMessage (ConfirmationEmailSent email) =
-    "En e-postkonfirmasjon har blitt sendt til " `mappend`
-    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"
-norwegianBokmålMessage BadSetPass = "Du må være logget inn for å sette et passord."
-norwegianBokmålMessage SetPassTitle = "Sett passord"
-norwegianBokmålMessage SetPass = "Sett et nytt passord"
-norwegianBokmålMessage NewPass = "Nytt passord"
-norwegianBokmålMessage ConfirmPass = "Bekreft"
-norwegianBokmålMessage PassMismatch = "Passordene stemte ikke overens, vennligst prøv igjen"
-norwegianBokmålMessage PassUpdated = "Passord oppdatert"
-norwegianBokmålMessage Facebook = "Logg inn med Facebook"
-norwegianBokmålMessage LoginViaEmail = "Logg inn med e-post"
-norwegianBokmålMessage InvalidLogin = "Ugyldig innlogging"
-norwegianBokmålMessage NowLoggedIn = "Du er nå logget inn"
-norwegianBokmålMessage LoginTitle = "Logg inn"
-norwegianBokmålMessage PleaseProvideUsername = "Vennligst fyll inn ditt brukernavn"
-norwegianBokmålMessage PleaseProvidePassword = "Vennligst fyll inn ditt passord"
-norwegianBokmålMessage NoIdentifierProvided = "No email/username provided"
-norwegianBokmålMessage InvalidEmailAddress = "Invalid email address provided"
-norwegianBokmålMessage PasswordResetTitle = "Password Reset"
-norwegianBokmålMessage ProvideIdentifier = "Email or Username"
-norwegianBokmålMessage SendPasswordResetEmail = "Send password reset email"
-norwegianBokmålMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
-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識別子がありません"
-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 = "メールアドレスを入力してください。確認メールが送られます"
-japaneseMessage ConfirmationEmailSentTitle = "確認メールを送信しました"
-japaneseMessage (ConfirmationEmailSent email) =
-    "確認メールを " `mappend`
-    email `mappend`
-    " に送信しました"
-japaneseMessage AddressVerified = "アドレスは認証されました。新しいパスワードを設定してください"
-japaneseMessage EmailVerifiedChangePass = "アドレスは認証されました。新しいパスワードを設定してください"
-japaneseMessage EmailVerified = "アドレスは認証されました"
-japaneseMessage InvalidKeyTitle = "認証キーが無効です"
-japaneseMessage InvalidKey = "申し訳ありません。無効な認証キーです"
-japaneseMessage InvalidEmailPass = "メールアドレスまたはパスワードが無効です"
-japaneseMessage BadSetPass = "パスワードを設定するためには、ログインしてください"
-japaneseMessage SetPassTitle = "パスワードの設定"
-japaneseMessage SetPass = "新しいパスワードを設定する"
-japaneseMessage NewPass = "新しいパスワード"
-japaneseMessage ConfirmPass = "確認"
-japaneseMessage PassMismatch = "パスワードが合いません。もう一度試してください"
-japaneseMessage PassUpdated = "パスワードは更新されました"
-japaneseMessage Facebook = "Facebookでログイン"
-japaneseMessage LoginViaEmail = "Eメールでログイン"
-japaneseMessage InvalidLogin = "無効なログインです"
-japaneseMessage NowLoggedIn = "ログインしました"
-japaneseMessage LoginTitle = "ログイン"
-japaneseMessage PleaseProvideUsername = "ユーザ名を入力してください"
-japaneseMessage PleaseProvidePassword = "パスワードを入力してください"
-japaneseMessage NoIdentifierProvided = "メールアドレス/ユーザ名が入力されていません"
-japaneseMessage InvalidEmailAddress = "メールアドレスが無効です"
-japaneseMessage PasswordResetTitle = "パスワードの再設定"
-japaneseMessage ProvideIdentifier = "メールアドレスまたはユーザ名"
-japaneseMessage SendPasswordResetEmail = "パスワード再設定用メールの送信"
-japaneseMessage PasswordResetPrompt = "以下にメールアドレスまたはユーザ名を入力してください。パスワードを再設定するためのメールが送信されます。"
-japaneseMessage InvalidUsernamePass = "ユーザ名とパスワードの組み合わせが間違っています"
-japaneseMessage (IdentifierNotFound ident) =
-  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"
-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."
-finnishMessage ConfirmationEmailSentTitle = "Vahvistussähköposti lähetetty."
-finnishMessage (ConfirmationEmailSent email) =
-    "Vahvistussähköposti on lähetty osoitteeseen " `mappend`
-    email `mappend`
-    "."
-
-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."
-finnishMessage BadSetPass = "Kirjaudu ensin sisään asettaaksesi salasanan"
-finnishMessage SetPassTitle = "Salasanan asettaminen"
-finnishMessage SetPass = "Aseta uusi salasana"
-finnishMessage NewPass = "Uusi salasana"
-finnishMessage ConfirmPass = "Vahvista"
-finnishMessage PassMismatch = "Salasanat eivät täsmää"
-finnishMessage PassUpdated = "Salasana vaihdettu"
-finnishMessage Facebook = "Kirjaudu Facebook-tilillä"
-finnishMessage LoginViaEmail = "Kirjaudu sähköpostitilillä"
-finnishMessage InvalidLogin = "Kirjautuminen epäonnistui"
-finnishMessage NowLoggedIn = "Olet nyt kirjautunut sisään"
-finnishMessage LoginTitle = "Kirjautuminen"
-finnishMessage PleaseProvideUsername = "Käyttäjänimi puuttuu"
-finnishMessage PleaseProvidePassword = "Salasana puuttuu"
-finnishMessage NoIdentifierProvided = "Sähköpostiosoite/käyttäjänimi puuttuu"
-finnishMessage InvalidEmailAddress = "Annettu sähköpostiosoite ei kelpaa"
-finnishMessage PasswordResetTitle = "Uuden salasanan tilaaminen"
-finnishMessage ProvideIdentifier = "Sähköpostiosoite tai käyttäjänimi"
-finnishMessage SendPasswordResetEmail = "Lähetä uusi salasana sähköpostitse"
-finnishMessage PasswordResetPrompt = "Anna sähköpostiosoitteesi tai käyttäjätunnuksesi alla, niin lähetämme uuden salasanan sähköpostitse."
-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"
-chineseMessage LoginOpenID = "用OpenID登录"
-chineseMessage LoginGoogle = "用Google帐户登录"
-chineseMessage LoginYahoo = "用Yahoo帐户登录"
-chineseMessage Email = "邮箱"
-chineseMessage UserName = "用户名"
-chineseMessage Password = "密码"
-chineseMessage CurrentPassword = "当前密码"
-chineseMessage Register = "注册"
-chineseMessage RegisterLong = "注册新帐户"
-chineseMessage EnterEmail = "输入你的邮箱地址，你将收到一封确认邮件。"
-chineseMessage ConfirmationEmailSentTitle = "确认邮件已发送"
-chineseMessage (ConfirmationEmailSent email) =
-    "确认邮件已发送至 " `mappend`
-    email `mappend`
-    "."
-chineseMessage AddressVerified = "地址验证成功，请设置新密码"
-chineseMessage EmailVerifiedChangePass = "地址验证成功，请设置新密码"
-chineseMessage EmailVerified = "地址验证成功"
-chineseMessage InvalidKeyTitle = "无效的验证码"
-chineseMessage InvalidKey = "对不起，验证码无效。"
-chineseMessage InvalidEmailPass = "无效的邮箱/密码组合"
-chineseMessage BadSetPass = "你需要登录才能设置密码"
-chineseMessage SetPassTitle = "设置密码"
-chineseMessage SetPass = "设置新密码"
-chineseMessage NewPass = "新密码"
-chineseMessage ConfirmPass = "确认"
-chineseMessage PassMismatch = "密码不匹配，请重新输入"
-chineseMessage PassUpdated = "密码更新成功"
-chineseMessage Facebook = "用Facebook帐户登录"
-chineseMessage LoginViaEmail = "用邮箱登录"
-chineseMessage InvalidLogin = "登录失败"
-chineseMessage NowLoggedIn = "登录成功"
-chineseMessage LoginTitle = "登录"
-chineseMessage PleaseProvideUsername = "请输入用户名"
-chineseMessage PleaseProvidePassword = "请输入密码"
-chineseMessage NoIdentifierProvided = "缺少邮箱/用户名"
-chineseMessage InvalidEmailAddress = "无效的邮箱地址"
-chineseMessage PasswordResetTitle = "重置密码"
-chineseMessage ProvideIdentifier = "邮箱或用户名"
-chineseMessage SendPasswordResetEmail = "发送密码重置邮件"
-chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。"
-chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"
-chineseMessage (IdentifierNotFound ident) = "邮箱/用户名不存在: " `mappend` ident
-chineseMessage Logout = "注销"
-chineseMessage LogoutTitle = "注销"
-chineseMessage AuthError = "验证错误"
-
-czechMessage :: AuthMessage -> Text
-czechMessage NoOpenID = "Nebyl nalezen identifikátor OpenID"
-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."
-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"
-czechMessage BadSetPass = "Pro nastavení hesla je vyžadováno přihlášení"
-czechMessage SetPassTitle = "Nastavit heslo"
-czechMessage SetPass = "Nastavit nové heslo"
-czechMessage NewPass = "Nové heslo"
-czechMessage ConfirmPass = "Potvrdit"
-czechMessage PassMismatch = "Hesla si neodpovídají, zkuste to znovu"
-czechMessage PassUpdated = "Heslo aktualizováno"
-czechMessage Facebook = "Přihlásit přes Facebook"
-czechMessage LoginViaEmail = "Přihlásit přes e-mail"
-czechMessage InvalidLogin = "Neplatné přihlášení"
-czechMessage NowLoggedIn = "Přihlášení proběhlo úspěšně"
-czechMessage LoginTitle = "Přihlásit"
-czechMessage PleaseProvideUsername = "Prosím, zadejte svoje uživatelské jméno"
-czechMessage PleaseProvidePassword = "Prosím, zadejte svoje heslo"
-czechMessage NoIdentifierProvided = "Nebyl poskytnut žádný e-mail nebo uživatelské jméno"
-czechMessage InvalidEmailAddress = "Zadaná e-mailová adresa je neplatná"
-czechMessage PasswordResetTitle = "Obnovení hesla"
-czechMessage ProvideIdentifier = "E-mail nebo uživatelské jméno"
-czechMessage SendPasswordResetEmail = "Poslat e-mail pro obnovení hesla"
-czechMessage PasswordResetPrompt = "Zadejte svou e-mailovou adresu nebo uživatelské jméno a bude vám poslán email pro obnovení hesla."
-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,58 +1,50 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Yesod.Auth.OpenId
     ( authOpenId
+    , authOpenIdExtended
     , forwardUrl
-    , claimedKey
-    , opLocalKey
-    , credsIdentClaimed
-    , IdentifierType (..)
     ) where
 
+#include "qq.h"
+
 import Yesod.Auth
 import qualified Web.Authenticate.OpenId as OpenId
 
 import Yesod.Form
-import Yesod.Core
-import Data.Text (Text, isPrefixOf)
+import Yesod.Handler
+import Yesod.Widget
+import Yesod.Request
+import Text.Cassius (cassius)
+import Text.Blaze (toHtml)
+import Data.Text (Text)
 import qualified Yesod.Auth.Message as Msg
-import UnliftIO.Exception (tryAny)
-import Data.Maybe (fromMaybe)
-import qualified Data.Text as T
+import Control.Exception.Lifted (SomeException, try)
 
 forwardUrl :: AuthRoute
 forwardUrl = PluginR "openid" ["forward"]
 
-data IdentifierType = Claimed | OPLocal
+authOpenId :: YesodAuth m => AuthPlugin m
+authOpenId = authOpenIdExtended []
 
-authOpenId :: YesodAuth master
-           => IdentifierType
-           -> [(Text, Text)] -- ^ extension fields
-           -> AuthPlugin master
-authOpenId idType extensionFields =
+authOpenIdExtended :: YesodAuth m => [(Text, Text)] -> AuthPlugin m
+authOpenIdExtended 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
-        -- code, but it shouldn't be necessary
-        let y :: a -> [(Text, Text)] -> Text
-            y = undefined
-        toWidget (\x -> [cassius|##{ident}
+        ident <- lift newIdent
+        addCassius
+            [QQ(cassius)|##{ident}
     background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
     padding-left: 18px;
-|] $ x `asTypeOf` y)
-        [whamlet|
-$newline never
+|]
+        [QQ(whamlet)|
+<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,82 +53,42 @@ $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
         case roid of
             Just oid -> do
-                tm <- getRouteToParent
                 render <- getUrlRender
-                let complete' = render $ tm complete
-                manager <- authHttpManager
-                eres <- tryAny $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager
+                toMaster <- getRouteToMaster
+                let complete' = render $ toMaster complete
+                master <- getYesod
+                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
+                        setMessage $ toHtml $ show (err :: SomeException)
+                        redirect $ toMaster LoginR
                     Right x -> redirect x
-            Nothing -> loginErrorMessageI LoginR Msg.NoOpenID
+            Nothing -> do
+                toMaster <- getRouteToMaster
+                setMessageI Msg.NoOpenID
+                redirect $ toMaster LoginR
     dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
     dispatch "GET" ["complete"] = do
         rr <- getRequest
-        completeHelper idType $ reqGetParams rr
+        completeHelper $ reqGetParams rr
     dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues
     dispatch "POST" ["complete"] = do
         (posts, _) <- runRequestBody
-        completeHelper idType posts
+        completeHelper posts
     dispatch _ _ = notFound
 
-completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
-completeHelper idType gets' = do
-    manager <- authHttpManager
-    eres <- tryAny $ OpenId.authenticateClaimed gets' manager
-    either onFailure onSuccess eres
-  where
-    onFailure err = do
-        tm <- getRouteToParent
-        loginErrorMessage (tm LoginR) $ T.pack $ show err
-    onSuccess oir = do
-            let claimed =
-                    case OpenId.oirClaimed oir of
-                        Nothing -> id
-                        Just (OpenId.Identifier i') -> ((claimedKey, i'):)
-                oplocal =
-                    case OpenId.oirOpLocal oir of
-                        OpenId.Identifier i' -> ((opLocalKey, i'):)
-                gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'
-                i = OpenId.identifier $
-                        case idType of
-                            OPLocal -> OpenId.oirOpLocal oir
-                            Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
-            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
--- available.
---
--- In the 'credsExtra' field of the 'Creds' datatype, you can lookup this key
--- to find the claimed identifier, if available.
---
--- > let finalID = fromMaybe (credsIdent creds)
--- >             $ lookup claimedKey (credsExtra creds)
---
--- Since 1.0.2
-claimedKey :: Text
-claimedKey = "__CLAIMED"
-
-opLocalKey :: Text
-opLocalKey = "__OPLOCAL"
-
--- | A helper function which will get the claimed identifier, if available, falling back to the OP local identifier.
---
--- See 'claimedKey'.
---
--- Since 1.0.2
-credsIdentClaimed :: Creds m -> Text
-
--- Prevent other backends from overloading the __CLAIMED value, which could
--- possibly open us to security holes.
-credsIdentClaimed c | credsPlugin c /= "openid" = credsIdent c
-
-credsIdentClaimed c = fromMaybe (credsIdent c)
-                    $ lookup claimedKey (credsExtra c)
+completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
+completeHelper gets' = do
+        master <- getYesod
+        eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master)
+        toMaster <- getRouteToMaster
+        let onFailure err = do
+            setMessage $ toHtml $ show (err :: SomeException)
+            redirect $ toMaster LoginR
+        let onSuccess (OpenId.Identifier ident, _) =
+                setCreds True $ Creds "openid" ident gets'
+        either onFailure onSuccess eres

yesod-auth/Yesod/Auth/Routes.hs

@@ -1,20 +0,0 @@
-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
-module Yesod.Auth.Routes where
-
-import Yesod.Core
-import Data.Text (Text)
-
-data Auth = Auth
-
-mkYesodSubData "Auth" [parseRoutes|
-/check                 CheckR      GET
-/login                 LoginR      GET
-/logout                LogoutR     GET POST
-/page/#Text/*Texts     PluginR
-|]

yesod-auth/Yesod/Auth/Rpxnow.hs

@@ -1,48 +1,44 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
 module Yesod.Auth.Rpxnow
     ( authRpxnow
     ) where
 
+#include "qq.h"
+
 import Yesod.Auth
 import qualified Web.Authenticate.Rpxnow as Rpxnow
 import Control.Monad (mplus)
 
-import Yesod.Core
+import Yesod.Handler
+import Yesod.Widget
+import Yesod.Request
+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
     login tm = do
-        render <- getUrlRender
-        let queryString = decodeUtf8With lenientDecode
-                        $ renderQuery True [("token_url", Just $ encodeUtf8 $ render $ tm $ PluginR "rpxnow" [])]
-        toWidget [hamlet|
-$newline never
-<iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
+        let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" []
+        addHamlet
+            [QQ(hamlet)|
+<iframe src="http://#{app}.rpxnow.com/openid/embed?token_url=@{url}" 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
-        Rpxnow.Identifier ident extra <- Rpxnow.authenticate apiKey token manager
+        master <- getYesod
+        Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master)
         let creds =
                 Creds "rpxnow" ident
                 $ maybe id (\x -> (:) ("verifiedEmail", x))
@@ -50,7 +46,7 @@ $newline never
                 $ maybe id (\x -> (:) ("displayName", x))
                     (fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
                   []
-        setCredsRedirect creds
+        setCreds True creds
     dispatch _ _ = notFound
 
 -- | Get some form of a display name.

yesod-auth/Yesod/Auth/Util/PasswordStore.hs

@@ -1,464 +0,0 @@
-{-# LANGUAGE OverloadedStrings, BangPatterns #-}
-{-# LANGUAGE CPP #-}
--- |
--- This is a fork of pwstore-fast, originally copyright (c) Peter Scott, 2011,
--- and released under a BSD-style licence.
---
--- 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
--- common. Some people store users' passwords in plain text. Then, when an
--- attacker manages to get their hands on this file, they have the passwords for
--- every user's account. One step up, but still wrong, is to simply hash all
--- passwords with SHA1 or something. This is vulnerable to rainbow table and
--- dictionary attacks. One step up from that is to hash the password along with
--- a unique salt value. This is vulnerable to dictionary attacks, since guessing
--- a password is very fast. The right thing to do is to use a slow hash
--- function, to add some small but significant delay, that will be negligible
--- for legitimate users but prohibitively expensive for someone trying to guess
--- passwords by brute force. That is what this library does. It iterates a
--- SHA256 hash, with a random salt, a few thousand times. This scheme is known
--- as PBKDF1, and is generally considered secure; there is nothing innovative
--- happening here.
---
--- The API here is very simple. What you store are called /password hashes/.
--- They are strings (technically, ByteStrings) that look like this:
---
--- > "sha256|14|jEWU94phx4QzNyH94Qp4CQ==|5GEw+jxP/4WLgzt9VS3Ee3nhqBlDsrKiB+rq7JfMckU="
---
--- Each password hash shows the algorithm, the strength (more on that later),
--- the salt, and the hashed-and-salted password. You store these on your server,
--- in a database, for when you need to verify a password. You make a password
--- hash with the 'makePassword' function. Here's an example:
---
--- > >>> makePassword "hunter2" 14
--- > "sha256|14|Zo4LdZGrv/HYNAUG3q8WcA==|zKjbHZoTpuPLp1lh6ATolWGIKjhXvY4TysuKvqtNFyk="
---
--- This will hash the password @\"hunter2\"@, with strength 14, 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
--- twice as long. When computers get faster, you can bump up the strength a
--- little bit to compensate. You can strengthen existing password hashes with
--- the 'strengthenPassword' function. Note that 'makePassword' needs to generate
--- random numbers, so its return type is 'IO' 'ByteString'. If you want to avoid
--- the 'IO' monad, you can generate your own salt and pass it to
--- 'makePasswordSalt'.
---
--- Your strength value should not be less than 12, and 14 is a good default
--- value at the time of this writing, in 2013.
---
--- Once you've got your password hashes, the second big thing you need to do
--- with them is verify passwords against them. When a user gives you a password,
--- you compare it with a password hash using the 'verifyPassword' function:
---
--- > >>> verifyPassword "wrong guess" passwordHash
--- > False
--- > >>> verifyPassword "hunter2" passwordHash
--- > True
---
--- These two functions are really all you need. If you want to make existing
--- password hashes stronger, you can use 'strengthenPassword'. Just pass it an
--- existing password hash and a new strength value, and it will return a new
--- password hash with that strength value, which will match the same password as
--- the old password hash.
---
--- 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 (
-
-        -- * Algorithms
-        pbkdf1,                 -- :: ByteString -> Salt -> Int -> ByteString
-        pbkdf2,                 -- :: ByteString -> Salt -> Int -> ByteString
-
-        -- * Registering and verifying passwords
-        makePassword,           -- :: ByteString -> Int -> IO ByteString
-        makePasswordWith,       -- :: (ByteString -> Salt -> Int -> ByteString) ->
-                                --    ByteString -> Int -> IO ByteString
-        makePasswordSalt,       -- :: ByteString -> ByteString -> Int -> ByteString
-        makePasswordSaltWith,   -- :: (ByteString -> Salt -> Int -> ByteString) ->
-                                --    ByteString -> Salt -> Int -> ByteString
-        verifyPassword,         -- :: ByteString -> ByteString -> Bool
-        verifyPasswordWith,     -- :: (ByteString -> Salt -> Int -> ByteString) ->
-                                --    (Int -> Int) -> ByteString -> ByteString -> Bool
-
-        -- * Updating password hash strength
-        strengthenPassword,     -- :: ByteString -> Int -> ByteString
-        passwordStrength,       -- :: ByteString -> Int
-
-        -- * Utilities
-        Salt,
-        isPasswordFormatValid,  -- :: ByteString -> Bool
-        genSaltIO,              -- :: IO Salt
-        genSaltRandom,          -- :: (RandomGen b) => b -> (Salt, b)
-        makeSalt,               -- :: ByteString -> Salt
-        exportSalt,             -- :: Salt -> ByteString
-        importSalt              -- :: ByteString -> Salt
-  ) where
-
-import qualified Crypto.MAC.HMAC as CH
-import qualified Crypto.Hash as CH
-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.STRef
-import Data.Bits
-import Data.ByteString.Char8 (ByteString)
-import Data.ByteString.Base64 (encode, decodeLenient)
-import System.IO
-import System.Random
-import Data.Maybe
-import qualified Control.Exception
-import Data.ByteArray (convert)
-
----------------------
--- Cryptographic base
----------------------
-
--- | PBKDF1 key-derivation function. Takes a password, a 'Salt', and a number of
--- iterations. The number of iterations should be at least 1000, and probably
--- more. 5000 is a reasonable number, computing almost instantaneously. This
--- will give a 32-byte 'ByteString' as output. Both the salt and this 32-byte
--- 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
-    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)
-
--- | Computes the hmacSHA256 of the given message, with the given 'Salt'.
-hmacSHA256 :: ByteString
-           -- ^ The secret (the salt)
-           -> ByteString
-           -- ^ The clear-text message
-           -> ByteString
-           -- ^ The encoded message
-hmacSHA256 secret msg =
-    convert (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."
-                  | otherwise =
-                      let !l = ceiling ((fromIntegral dkLen / fromIntegral hLen) :: Double)
-                          !r = dkLen - (l - 1) * hLen
-                          chunks = [f i | i <- [1 .. l]]
-                      in (B.concat . init $ chunks) `B.append` B.take r (last chunks)
-
-    -- The @f@ function, as defined in the spec.
-    -- It calls 'u' under the hood.
-    f :: Int -> ByteString
-    f i = let !u1 = hmacSHA256 password (salt `B.append` int i)
-      -- Using the ST Monad, for maximum performance.
-      in runST $ do
-          u <- newSTRef u1
-          accum <- newSTRef u1
-          forM_ [2 .. c] $ \_ -> do
-            modifySTRef' u (hmacSHA256 password)
-            currentU <- readSTRef u
-            modifySTRef' accum (`xor'` currentU)
-          readSTRef accum
-
-    -- int(i), as defined in the spec.
-    int :: Int -> ByteString
-    int i = let str = BL.unpack . Binary.encode $ i
-            in BS.pack $ drop (length str - 4) str
-
-    -- | A convenience function to XOR two 'ByteString' together.
-    xor' :: ByteString -> ByteString -> ByteString
-    xor' !b1 !b2 = BS.pack $ BS.zipWith xor b1 b2
-
--- | 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
-  where
-    def :: IOError -> IO Salt
-    def _ = genSaltSysRandom
-
--- | Generate a 'Salt' from @\/dev\/urandom@.
-genSaltDevURandom :: IO Salt
-genSaltDevURandom = withFile "/dev/urandom" ReadMode $ \h -> do
-                      rawSalt <- B.hGet h 16
-                      return $ makeSalt rawSalt
-
--- | Generate a 'Salt' from 'System.Random'.
-genSaltSysRandom :: IO Salt
-genSaltSysRandom = randomChars >>= return . makeSalt . B.pack
-    where randomChars = sequence $ replicate 16 $ randomRIO ('\NUL', '\255')
-
------------------------
--- Password hash format
------------------------
-
--- Format: "sha256|strength|salt|hash", where strength is an unsigned int, salt
--- is a base64-encoded 16-byte random number, and hash is a base64-encoded hash
--- value.
-
--- | Try to parse a password hash.
-readPwHash :: ByteString -> Maybe (Int, Salt, ByteString)
-readPwHash pw | length broken /= 4
-                || algorithm /= "sha256"
-                || B.length hash /= 44 = Nothing
-              | otherwise = case B.readInt strBS of
-                              Just (strength, _) -> Just (strength, SaltBS salt, hash)
-                              Nothing -> Nothing
-    where broken = B.split '|' pw
-          [algorithm, strBS, salt, hash] = broken
-
--- | Encode a password hash, from a @(strength, salt, hash)@ tuple, where
--- strength is an 'Int', and both @salt@ and @hash@ are base64-encoded
--- 'ByteString's.
-writePwHash :: (Int, Salt, ByteString) -> ByteString
-writePwHash (strength, SaltBS salt, hash) =
-    B.intercalate "|" ["sha256", B.pack (show strength), salt, hash]
-
------------------
--- High level API
------------------
-
--- | Hash a password with a given strength (14 is a good default). The output of
--- this function can be written directly to a password file or
--- 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
-
--- | A generic version of 'makePassword', which allow the user
--- to choose the algorithm to use.
---
--- >>> makePasswordWith pbkdf1 "password" 14
---
--- @since 1.4.18
---
-makePasswordWith :: (ByteString -> Salt -> Int -> ByteString)
-                 -- ^ The algorithm to use (e.g. pbkdf1)
-                 -> ByteString
-                 -- ^ The password to encrypt
-                 -> Int
-                 -- ^ log2 of the number of iterations
-                 -> IO ByteString
-makePasswordWith algorithm password strength = do
-  salt <- genSaltIO
-  return $ makePasswordSaltWith algorithm (2^) password salt strength
-
--- | A generic version of 'makePasswordSalt', meant to give the user
--- the maximum control over the generation parameters.
--- 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)
-                     -- ^ A function to modify the strength
-                     -> ByteString
-                     -- ^ A password, given as clear text
-                     -> Salt
-                     -- ^ A hash 'Salt'
-                     -> Int
-                     -- ^ The password strength (e.g. @10000, 20000, etc.@)
-                     -> ByteString
-makePasswordSaltWith algorithm strengthModifier pwd salt strength = writePwHash (strength, salt, hash)
-    where hash = encode $ algorithm pwd salt (strengthModifier strength)
-
--- | Hash a password with a given strength (14 is a good default), using a given
--- salt. The output of this function can be written directly to a password file
--- or database. Example:
---
--- > >>> makePasswordSalt "hunter2" (makeSalt "72cd18b5ebfe6e96") 14
--- > "sha256|14|NzJjZDE4YjVlYmZlNmU5Ng==|yuiNrZW3KHX+pd0sWy9NTTsy5Yopmtx4UYscItSsoxc="
---
--- @since 1.4.18
---
-makePasswordSalt :: ByteString -> Salt -> Int -> ByteString
-makePasswordSalt = makePasswordSaltWith pbkdf1 (2^)
-
--- | 'verifyPasswordWith' @algorithm userInput pwHash@ verifies
--- the password @userInput@ given by the user against the stored password
--- hash @pwHash@, with the hashing algorithm @algorithm@.  Returns 'True' if the
--- given password is correct, and 'False' if it is not.
--- This function allows the programmer to specify the algorithm to use,
--- e.g. 'pbkdf1' or 'pbkdf2'.
--- Note: If you want to verify a password previously generated with
--- 'makePasswordSaltWith', but without modifying the number of iterations,
--- you can do:
---
--- > >>> 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)
-                   -- ^ A function to modify the strength
-                   -> ByteString
-                   -- ^ User password
-                   -> ByteString
-                   -- ^ The generated hash (e.g. sha256|14...)
-                   -> Bool
-verifyPasswordWith algorithm strengthModifier userInput pwHash =
-    case readPwHash pwHash of
-      Nothing -> False
-      Just (strength, salt, goodHash) ->
-          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^)
-
--- | Try to strengthen a password hash, by hashing it some more
--- times. @'strengthenPassword' pwHash new_strength@ will return a new password
--- hash with strength at least @new_strength@. If the password hash already has
--- strength greater than or equal to @new_strength@, then it is returned
--- unmodified. If the password hash is invalid and does not parse, it will be
--- returned without comment.
---
--- 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
-      Nothing -> pwHash
-      Just (oldstr, salt, hashB64) ->
-          if oldstr < newstr then
-              writePwHash (newstr, salt, newHash)
-          else
-              pwHash
-          where newHash = encode $ hashRounds hash extraRounds
-                extraRounds = (2^newstr) - (2^oldstr)
-                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
-                            Just (strength, _, _) -> strength
-
-------------
--- Utilities
-------------
-
--- | A salt is a unique random value which is stored as part of the password
--- 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 =
-                                error "Salt too short. Minimum length is 8 characters."
-                            | otherwise = salt
-
--- | 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
-
--- | Generate a 'Salt' with 128 bits of data taken from a given random number
--- 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 = []
-          rands g n = (a, g') : rands g' (n-1 :: Int)
-              where (a, g') = randomR ('\NUL', '\255') g
-          salt   = makeSalt $ B.pack $ map fst (rands gen 16)
-          newgen = snd $ last (rands gen 16)
-
-#if !MIN_VERSION_base(4, 6, 0)
--- | Strict version of 'modifySTRef'
-modifySTRef' :: STRef s a -> (a -> a) -> ST s ()
-modifySTRef' ref f = do
-    x <- readSTRef ref
-    let x' = f x
-    x' `seq` writeSTRef ref x'
-#endif

yesod-auth/browserid.hs

@@ -11,11 +11,8 @@ import Text.Hamlet (hamlet)
 import Control.Monad.IO.Class (liftIO)
 import Yesod.Form
 import Network.Wai.Handler.Warp (run)
-import Network.HTTP.Conduit
-import Network.TLS
-import Network.Wai.Middleware.RequestLogger
 
-data BID = BID { httpManager :: Manager }
+data BID = BID
 
 mkYesod "BID" [parseRoutes|
 / RootR GET
@@ -24,31 +21,27 @@ mkYesod "BID" [parseRoutes|
 |]
 
 getRootR :: Handler ()
-getRootR = redirect $ AuthR LoginR
+getRootR = redirect RedirectTemporary $ AuthR LoginR
 
-getAfterLoginR :: Handler Html
+getAfterLoginR :: Handler RepHtml
 getAfterLoginR = do
     mauth <- maybeAuthId
-    defaultLayout $ toWidget [hamlet|
+    defaultLayout $ addHamlet [hamlet|
 <p>Auth: #{show mauth}
 |]
 
 instance Yesod BID where
-    approot = ApprootStatic "http://localhost:3000"
+    approot _ = "http://localhost:3000"
 
 instance YesodAuth BID where
     type AuthId BID = Text
     loginDest _ = AfterLoginR
     logoutDest _ = AuthR LoginR
     getAuthId = return . Just . credsIdent
-    authPlugins _ = [authBrowserId def]
-    authHttpManager = httpManager
-    maybeAuthId = lookupSession credsKey
+    authPlugins = [authBrowserId']
 
 instance RenderMessage BID FormMessage where
     renderMessage _ _ = defaultFormMessage
 
 main :: IO ()
-main = do
-    m <- newManager conduitManagerSettings
-    toWaiApp (BID m) >>= run 3000 . logStdoutDev
+main = toWaiApp BID >>= run 3000

yesod-auth/include/qq.h

@@ -0,0 +1,10 @@
+
+-- CPP macro which choses which quasyquotes syntax to use depending
+-- on GHC version.
+--
+-- QQ stands for quasyquote.
+#if GHC7
+# define QQ(x) x
+#else
+# define QQ(x) $x
+#endif

yesod-auth/kerberos.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+import Yesod
+import Yesod.Auth
+import Yesod.Form
+import Yesod.Auth.Kerberos
+
+data Kerberos = Kerberos
+
+mkYesod "Kerberos" [parseRoutes|
+/ RootR GET
+/after AfterLoginR GET
+/auth AuthR Auth getAuth
+|]
+
+getRootR :: Handler ()
+getRootR = redirect RedirectTemporary $ AuthR LoginR
+
+getAfterLoginR :: Handler RepHtml
+getAfterLoginR = defaultLayout $ return ()
+
+instance Yesod Kerberos where
+    approot _ = "http://localhost:3000"
+
+instance YesodAuth Kerberos where
+    type AuthId Kerberos = String
+    loginDest _ = AfterLoginR
+    logoutDest _ = AuthR LoginR
+    getAuthId _ = do
+        liftIO $ putStrLn "getAuthId"
+        return $ Just "foo"
+    authPlugins = [authKerberos]
+
+instance RenderMessage Kerberos FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+main :: IO ()
+main = warpDebug 3000 Kerberos

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 _ = "http://localhost:3000"
 
 instance YesodAuth BID where
     type AuthId BID = Text
     loginDest _ = AfterLoginR
     logoutDest _ = AuthR LoginR
-    getAuthId = return . Just . credsIdentClaimed
-    authPlugins _ = [authOpenId Claimed []]
+    getAuthId = return . Just . credsIdent
+    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,68 +1,51 @@
-cabal-version:   >=1.10
 name:            yesod-auth
-version:         1.6.11.2
-license:         MIT
+version:         0.8.1
+license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
 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>
-extra-source-files: persona_sign_in_blue.png
-                    README.md
-                    ChangeLog.md
+extra-source-files: include/qq.h
+description:     Authentication for Yesod.
 
-flag network-uri
-  description: Get Network.URI from the network-uri package
-  default: True
+flag ghc7
 
 library
-    default-language: Haskell2010
-    build-depends:   base                    >= 4.10      && < 5
-                   , aeson                   >= 0.7
-                   , attoparsec-aeson        >= 2.1
-                   , authenticate            >= 1.3.4
-                   , base16-bytestring
-                   , base64-bytestring
-                   , binary
-                   , blaze-builder
-                   , blaze-html              >= 0.5
-                   , blaze-markup            >= 0.5.1
-                   , bytestring              >= 0.9.1.4
-                   , conduit                 >= 1.3
-                   , conduit-extra
-                   , containers
-                   , cryptonite
-                   , data-default
-                   , email-validate          >= 1.0
-                   , file-embed
-                   , http-client             >= 0.5
-                   , http-client-tls
-                   , http-conduit            >= 2.1
-                   , http-types
-                   , memory
-                   , nonce                   >= 1.0.2     && < 1.1
-                   , persistent              >= 2.8
-                   , random                  >= 1.0.0.2
-                   , safe
-                   , shakespeare
+    if flag(ghc7)
+        build-depends:   base                >= 4.3      && < 5
+        cpp-options:     -DGHC7
+    else
+        build-depends:   base                >= 4        && < 4.3
+    build-depends:   authenticate            >= 1.0       && < 1.1
+                   , bytestring              >= 0.9.1.4   && < 0.10
+                   , yesod-core              >= 0.10.1    && < 0.11
+                   , wai                     >= 1.1       && < 1.2
                    , template-haskell
-                   , text                    >= 0.7
-                   , time
-                   , transformers            >= 0.2.2
-                   , unliftio
-                   , unliftio-core
+                   , pureMD5                 >= 2.0       && < 2.2
+                   , random                  >= 1.0.0.2  && < 1.1
+                   , text                    >= 0.7       && < 0.12
+                   , mime-mail               >= 0.3       && < 0.5
+                   , blaze-html              >= 0.4.1.3   && < 0.5
+                   , yesod-persistent        >= 0.3.1     && < 0.4
+                   , hamlet                  >= 0.10      && < 0.11
+                   , shakespeare-css         >= 0.10      && < 0.11
+                   , yesod-json              >= 0.3.1     && < 0.4
+                   , containers
                    , unordered-containers
-                   , wai                     >= 1.4
-                   , yesod-core              >= 1.6       && < 1.7
-                   , yesod-form              >= 1.6       && < 1.8
-                   , yesod-persistent        >= 1.6
-
-    if flag(network-uri)
-      build-depends: network-uri >= 2.6
+                   , yesod-form              >= 0.4.1     && < 0.5
+                   , transformers            >= 0.2.2     && < 0.3
+                   , persistent              >= 0.8       && < 0.9
+                   , persistent-template     >= 0.8       && < 0.9
+                   , SHA                     >= 1.4.1.3   && < 1.6
+                   , http-conduit            >= 1.2.5     && < 1.3
+                   , aeson                   >= 0.5
+                   , pwstore-fast            >= 2.2       && < 3
+                   , lifted-base             >= 0.1       && < 0.2
 
     exposed-modules: Yesod.Auth
                      Yesod.Auth.BrowserId
@@ -70,12 +53,11 @@ library
                      Yesod.Auth.Email
                      Yesod.Auth.OpenId
                      Yesod.Auth.Rpxnow
+                     Yesod.Auth.HashDB
                      Yesod.Auth.Message
-                     Yesod.Auth.GoogleEmail2
-                     Yesod.Auth.Hardcoded
-                     Yesod.Auth.Util.PasswordStore
-    other-modules:   Yesod.Auth.Routes
+                     Yesod.Auth.GoogleEmail
     ghc-options:     -Wall
+    include-dirs: include
 
 source-repository head
   type:     git

yesod-bin/AddHandler.hs

@@ -1,259 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
-module AddHandler (addHandler) where
-
-import Prelude hiding (readFile)
-import System.IO  (hFlush, stdout)
-import Data.Char  (isLower, toLower, isSpace)
-import Data.List  (isPrefixOf, isSuffixOf, stripPrefix)
-import Data.Maybe (fromMaybe, listToMaybe)
-import qualified Data.Text as T
-import qualified Data.Text.IO as TIO
-#if MIN_VERSION_Cabal(3, 7, 0)
-import Distribution.Simple.PackageDescription (readGenericPackageDescription)
-#elif MIN_VERSION_Cabal(2, 2, 0)
-import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
-#elif MIN_VERSION_Cabal(2, 0, 0)
-import Distribution.PackageDescription.Parse (readGenericPackageDescription)
-#else
-import Distribution.PackageDescription.Parse (readPackageDescription)
-#endif
-#if MIN_VERSION_Cabal(3, 6, 0)
-import Distribution.Utils.Path
-#endif
-import Distribution.PackageDescription.Configuration (flattenPackageDescription)
-import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)
-import Distribution.Verbosity (normal)
-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
-cmdLineArgsError = "You have to specify a route name if you want to add handler with command line arguments."
-
-addHandler :: Maybe String -> Maybe String -> [String] -> IO ()
-addHandler (Just route) pat met = do
-    cabal <- getCabal
-    checked <- checkRoute route cabal
-    let routePair = case checked of
-          Left err@EmptyRoute -> (error . show) err
-          Left err@RouteCaseError -> (error . show) err
-          Left err@(RouteExists _) -> (error . show) err
-          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
-getRoutesFilePath = do
-    let oldPath = "config/routes"
-    oldExists <- doesFileExist oldPath
-    pure $ if oldExists
-        then oldPath
-        else "config/routes.yesodroutes"
-
-addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO ()
-addHandlerFiles cabal (name, handlerFile) pattern methods = do
-    src <- getSrcDir cabal
-    let applicationFile = concat [src, "/Application.hs"]
-    modify applicationFile $ fixApp name
-    modify cabal $ fixCabal name
-    routesPath <- getRoutesFilePath
-    modify routesPath $ fixRoutes name pattern methods
-    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
-
-    go [] = [l ""]
-    go (x:xs)
-        | Just y <- stripPrefix "import " x, "Handler." `isPrefixOf` dropWhile (== ' ') y = l (takeWhile (== ' ') y) : x : xs
-        | otherwise = x : go xs
-
-fixCabal :: String -> String -> String
-fixCabal name orig =
-    unlines $ (reverse $ go $ reverse libraryLines) ++ restLines
-  where
-    origLines = lines orig
-
-    (libraryLines, restLines) = break isExeTestBench origLines
-
-    isExeTestBench x = any
-        (\prefix -> prefix `isPrefixOf` x)
-        [ "executable"
-        , "test-suite"
-        , "benchmark"
-        ]
-
-    l = "                  Handler." ++ name
-
-    go [] = [l]
-    go (x:xs)
-        | "Handler." `isPrefixOf` x' = (spaces ++ "Handler." ++ name) : x : xs
-        | otherwise = x : go xs
-      where
-        (spaces, x') = span isSpace x
-
-fixRoutes :: String -> String -> String -> String -> String
-fixRoutes name pattern methods fileContents =
-    fileContents ++ l
-  where
-    l = concat
-        [ startingCharacter
-        , 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
-    $ ("module Handler." ++ name ++ " where")
-    : ""
-    : "import Import"
-    : concatMap go (words methods)
-  where
-    go method =
-        [ ""
-        , concat $ func : " :: " : map toArrow types ++ ["Handler Html"]
-        , concat
-            [ func
-            , " "
-            , concatMap toArgument types
-            , "= error \"Not yet implemented: "
-            , func
-            , "\""
-            ]
-        ]
-      where
-        func = concat [map toLower method, name, "R"]
-
-    types = getTypes pattern
-
-    toArrow t = concat [t, " -> "]
-    toArgument t = concat [uncapitalize t, " "]
-
-    getTypes "" = []
-    getTypes ('/':rest) = getTypes rest
-    getTypes (c:rest) | c `elem` "#*" =
-        typ : getTypes rest'
-      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/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,533 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE CPP                 #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE TemplateHaskell     #-}
-module Devel
-    ( devel
-    , develSignal
-    , DevelOpts(..)
-    ) where
-
-import           Control.Applicative                   ((<|>))
-import           UnliftIO                              (race_)
-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.Utils             as D
-import qualified Distribution.Verbosity                as D
-import           Network.HTTP.Client                   (newManager)
-import           Network.HTTP.Client                   (managerSetProxy,
-                                                        noProxy)
-import           Network.HTTP.Client.TLS               (tlsManagerSettings)
-import           Network.HTTP.ReverseProxy             (ProxyDest (ProxyDest),
-                                                        waiProxyToSettings,
-                                                        wpsOnExc, wpsTimeout,
-#if MIN_VERSION_http_reverse_proxy(0, 6, 0)
-                                                        defaultWaiProxySettings
-#else
-                                                        def
-#endif
-                                                        )
-import qualified Network.HTTP.ReverseProxy             as ReverseProxy
-import           Network.HTTP.Types                    (status200, status503)
-import qualified Network.Socket
-import           Network.Wai                           (requestHeaderHost,
-                                                        requestHeaders,
-                                                        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,
-                                                        getExecutablePath)
-import           System.FilePath                       (takeDirectory,
-                                                        takeFileName, (</>))
-import           System.FSNotify
-import           System.IO                             (stdout, stderr)
-import           System.IO.Error                       (isDoesNotExistError)
-import           Data.Conduit.Process.Typed
-
--- We have two special files:
---
--- * The terminate file tells the child process to die simply by being
--- present. Ideally we'd handle this via killing the process
--- 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
-
--- used by scaffolded app, cannot change
-specialFilePath TermFile = "yesod-devel/devel-terminate"
-
--- only used internally, can change
-specialFilePath SignalFile = "yesod-devel/rebuild"
-
--- | Write a special file
-writeSpecialFile :: SpecialFile -> IO ()
-writeSpecialFile sp = do
-    let fp = specialFilePath sp
-    createDirectoryIfMissing True $ takeDirectory fp
-    now <- getCurrentTime
-    writeFile fp $ show now
-
--- | Remove a special file
-removeSpecialFile :: SpecialFile -> IO ()
-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
-      , successHook     :: Maybe String
-      , develPort       :: Int
-      , develTlsPort    :: Int
-      , proxyTimeout    :: Int
-      , useReverseProxy :: Bool
-      , develHost       :: Maybe String
-      , cert            :: Maybe (FilePath, FilePath)
-      } deriving (Show, Eq)
-
--- | Run a reverse proxy from the develPort and develTlsPort ports to
--- the app running in appPortVar. If there is no response on the
--- application port, give an appropriate message to the user.
-reverseProxy :: DevelOpts -> TVar Int -> IO ()
-reverseProxy opts appPortVar = do
-    manager <- newManager $ managerSetProxy noProxy tlsManagerSettings
-    let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")]
-        sayV = when (verbose opts) . sayString
-    let onExc _ req
-            | maybe False (("application/json" `elem`) . parseHttpAccept)
-                (lookup "accept" $ requestHeaders req) =
-                    return $ responseLBS status503
-                        [ ("Retry-After", "1")
-                        ]
-                        "{\"message\":\"Recompiling\"}"
-            | otherwise = return $ responseLBS status200
-                [ ("content-type", "text/html")
-                , ("Refresh", "1")
-                ]
-                refreshHtml
-
-    let proxyApp = waiProxyToSettings
-                (const $ do
-                    appPort <- atomically $ readTVar appPortVar
-                    sayV $ "revProxy: appPort " ++ (show appPort)
-                    return $
-                        ReverseProxy.WPRProxyDest
-                        $ ProxyDest "127.0.0.1" appPort)
-#if MIN_VERSION_http_reverse_proxy(0, 6, 0)
-                defaultWaiProxySettings
-#else
-                def
-#endif
-                    { wpsOnExc = \e req f -> onExc e req >>= f
-                    , wpsTimeout =
-                        if proxyTimeout opts == 0
-                            then Nothing
-                            else Just (1000000 * proxyTimeout opts)
-                    }
-                manager
-        defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings
-        runProxyTls port app = do
-          let certDef = $(embedFile "certificate.pem")
-              keyDef = $(embedFile "key.pem")
-              theSettings = case cert opts of
-                Nothing -> tlsSettingsMemory certDef keyDef
-                Just (c,k) -> tlsSettings c k
-          runTLS theSettings (setPort port defaultSettings') $ \req send -> do
-            let 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"
-    case es of
-        Left _ -> return False
-        Right s -> do
-            Network.Socket.close s
-            return True
-
--- | Get a random, unused port.
-getNewPort :: DevelOpts -> IO Int
-getNewPort opts = do
-    (port, socket) <- bindRandomPortTCP "*"
-    when (verbose opts) $ sayString $ "Got new port: " ++ show port
-    Network.Socket.close socket
-    return port
-
--- | 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.
-checkDevelFile :: IO FilePath
-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"
-
-    -- Friendly message to the user
-    say "Yesod devel server. Enter 'quit' or hit Ctrl-C to quit."
-
-    -- 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)
-    gpd    <- D.readGenericPackageDescription D.normal cabal
-#else
-    gpd    <- D.readPackageDescription D.normal cabal
-#endif
-
-    let pd = D.packageDescription gpd
-        D.PackageIdentifier packageNameWrapped _version = D.package pd
-#if MIN_VERSION_Cabal(2, 0, 0)
-        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
-    sayV = when (verbose opts) . sayString
-
-    -- Leverage "stack build --file-watch" to do the build
-    runStackBuild :: TVar Int -> [Char] -> Set.Set [Char] -> IO ()
-    runStackBuild appPortVar packageName availableFlags = do
-        -- We call into this app for the devel-signal command
-        myPath <- getExecutablePath
-        let procConfig = setStdout createSource
-                       $ setStderr createSource
-                       $ setCreateGroup True -- because need when yesod-bin killed and kill child ghc
-                       $ proc "stack" $
-                [ "build"
-                , "--fast"
-                , "--file-watch"
-
-                -- Indicate the component we want
-                , packageName ++ ":lib"
-
-                -- signal the watcher that a build has succeeded
-                , "--exec", myPath ++ " devel-signal"
-                ] ++
-
-                -- Turn on relevant flags
-                concatMap
-                    (\flagName -> [ "--flag", packageName ++ ":" ++ flagName])
-                    (Set.toList $ Set.intersection
-                        availableFlags
-                        (Set.fromList ["dev", "library-only"])) ++
-
-                -- Add the success hook
-                (case successHook opts of
-                    Nothing -> []
-                    Just h -> ["--exec", h]) ++
-
-                -- Any extra args passed on the command line
-                passThroughArgs
-
-        sayV $ show procConfig
-        buildStarted <- newTVarIO False
-        -- Monitor the stdout and stderr content from the build process. Any
-        -- time some output comes, we invalidate the currently running app by
-        -- changing the destination port for reverse proxying to -1. We also
-        -- make sure that all content to stdout or stderr from the build
-        -- 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
-    -- whenever the signal file is modified.
-    withChangedVar :: (TVar Bool -> IO a) -> IO a
-    withChangedVar inner = withManager $ \manager -> do
-        -- Variable indicating that the signal file has been changed. We
-        -- reset it each time we handle the signal.
-        changedVar <- newTVarIO False
-
-        -- 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
-        -- True each time it's changed.
-        void $ watchDir manager
-                -- Using fromString to work with older versions of fsnotify
-                -- that use system-filepath
-                (fromString (takeDirectory develSignalFile'))
-                (\e -> eventPath e == fromString develSignalFile')
-                (const $ atomically $ writeTVar changedVar True)
-
-        -- Run the inner action
-        inner changedVar
-
-    -- Each time the library builds successfully, run the application
-    runApp :: TVar Int -> TVar Bool -> String -> IO b
-    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"
-
-        -- We're going to set the PORT and DISPLAY_PORT variables for
-        -- the child below. Also need to know if the env program
-        -- exists.
-        env <- fmap Map.fromList getEnvironment
-        hasEnv <- fmap isJust $ findExecutable "env"
-
-        -- Keep looping forever, print any synchronous exceptions,
-        -- and eventually die from an async exception from one of
-        -- the other threads (via race_ above).
-        forever $ Ex.handleAny (\e -> sayErrString $ "Exception in runApp: " ++ show e) $ do
-            -- Get the port the child should listen on, and tell
-            -- the reverse proxy about it
-            newPort <-
-                if useReverseProxy opts
-                    then getNewPort opts
-                    -- no reverse proxy, so use the develPort directly
-                    else return (develPort opts)
-            atomically $ writeTVar appPortVar newPort
-
-            -- Modified environment
-            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
-            removeSpecialFile TermFile
-
-            -- Launch the main function in the Main module defined
-            -- in the file develHsPath. We use ghc instead of
-            -- runghc to avoid the extra (confusing) resident
-            -- runghc process. Starting with GHC 8.0.2, that will
-            -- not be necessary.
-
-            {- Hmm, unknown errors trying to get this to work. Just doing the
-             - runghc thing instead.
-
-            let procDef = setStdin closed $ setEnv env' $ proc "stack"
-                    [ "ghc"
-                    , "--"
-                    , develHsPath
-                    , "-e"
-                    , "Main.main"
-                    ]
-            -}
-
-            -- Nix support in Stack doesn't pass along env vars by
-            -- default, so we use the env command. But if the command
-            -- isn't available, just set the env var. I'm sure this
-            -- will break _some_ combination of systems, but we'll
-            -- deal with that later. Previous issues:
-            --
-            -- 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
-
-            -- Start running the child process with GHC
-            withProcess procDef $ \p -> do
-                -- Wait for either the process to exit, or for a new build to come through
-                eres <- atomically (fmap Left (waitExitCodeSTM p) <|> fmap Right
-                    (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
-                        ec <- waitExitCode p
-                        sayV $ "Expected: child process exited with " ++ show ec

yesod-bin/HsFile.hs

@@ -1,18 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-module HsFile (mkHsFile) where
-import Text.ProjectTemplate (createTemplate)
-import Conduit
-import qualified Data.ByteString as BS
-import Control.Monad.IO.Class (liftIO)
-import Data.String (fromString)
-
-mkHsFile :: IO ()
-mkHsFile = runConduitRes
-         $ sourceDirectory "."
-        .| readIt
-        .| createTemplate
-        .| mapM_C (liftIO . BS.putStr)
-  where
-    -- Reads a filepath from upstream and dumps a pair of (filepath, filecontents)
-    readIt = mapC $ \i -> (fromString i, liftIO $ BS.readFile i)

yesod-bin/Keter.hs

@@ -1,140 +0,0 @@
-{-# 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 Control.Monad
-import System.Directory hiding (findFiles)
-import Data.Maybe (mapMaybe,isJust,maybeToList)
-import Data.Monoid
-import System.FilePath ((</>))
-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
-    ec <- rawSystem a b
-    unless (ec == ExitSuccess) $ exitWith ec
-
-keter :: String -- ^ cabal command
-      -> Bool -- ^ no build?
-      -> Bool -- ^ no copy to?
-      -> [String] -- ^ build args
-      -> IO ()
-keter cabal noBuild noCopyTo buildArgs = do
-    ketercfg <- keterConfig
-    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
-                    _ ->
-                        case Map.lookup "user-edited" value of
-                            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
-            [x] -> return x
-            [] -> error "No cabal file found"
-            _ -> error "Too many cabal files found"
-
-    let findFiles (Object v) =
-            mapM_ go $ Map.toList v
-          where
-            go ("exec", String s) = tellFile s
-            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
-            eres <- try $ readProcessWithExitCode "stack" ["query"] "" :: IO (Either IOException (ExitCode, String, String))
-            return $ either (\_ -> False) (\(ec, _, _) -> (ec == ExitSuccess)) eres
-
-        let inStackExec = isJust $ lookup "STACK_EXE" env'
-            mStackYaml = lookup "STACK_YAML" env'
-            useStack = inStackExec || isJust mStackYaml || stackQueryRunSuccess
-
-        if useStack
-            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
-        Just (String s) ->
-            let baseArgs = [fp, T.unpack s] :: [String]
-
-                scpArgs =
-                    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/LICENSE

@@ -1,20 +0,0 @@
-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
-"Software"), to deal in the Software without restriction, including
-without limitation the rights to use, copy, modify, merge, publish,
-distribute, sublicense, and/or sell copies of the Software, and to
-permit persons to whom the Software is furnished to do so, subject to
-the following conditions:
-
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

yesod-bin/Options.hs

@@ -1,106 +0,0 @@
-{-# LANGUAGE PatternGuards       #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE CPP                 #-}
-
-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)
-import qualified Data.Map                  as M
-import           Data.Maybe                (mapMaybe)
-import           Data.Monoid
-import           Options.Applicative
-import           Options.Applicative.Types
-import           System.Directory
-import           System.Environment
-import           System.FilePath           ((</>))
-
--- | inject defaults from either files or environments
---   in order of priority:
---    1. command line arguments: --long-option=value
---    2. environment variables: PREFIX_COMMAND_LONGOPTION=value
---    3. $HOME/.prefix/config:  prefix.command.longoption=value
---
--- note: this automatically injects values for standard options and flags
---       (also inside subcommands), but not for more complex parsers that use BindP
---       (like `many'). As a workaround a single special case is supported,
---       for `many' arguments that generate a list of strings.
-
-injectDefaults :: String                                     -- ^ prefix, program name
-               -> [(String, a -> [String] -> a)]             -- ^ append extra options for arguments that are lists of strings
-               -> ParserInfo a                               -- ^ original parsers
-               -> IO (ParserInfo a)
-injectDefaults prefix lenses parser = do
-  e      <- getEnvironment
-  config <- (readFile . (</> "config") =<< getAppUserDataDirectory prefix)
-              `E.catch` \(_::E.SomeException) -> return ""
-  let env = M.fromList . filter ((==[prefix]) . take 1 . fst) $
-               configLines config <>                              -- config first
-               map (\(k,v) -> (splitOn "_" $ map toLower k, v)) e -- env vars override config
-      p' =  parser { infoParser = injectDefaultP env [prefix] (infoParser parser) }
-  return $ foldl' (\p (key,l) -> fmap (updateA env key l) p) p' lenses
-
-updateA :: M.Map [String] String -> String -> (a -> [String] -> a) -> a -> a
-updateA env key upd a =
-  case M.lookup (splitOn "." key) env of
-    Nothing -> a
-    Just v  -> upd a (splitOn ":" v)
-
--- | really simple key/value file reader:   x.y = z -> (["x","y"],"z")
-configLines :: String -> [([String], String)]
-configLines = mapMaybe (mkLine . takeWhile (/='#')) . lines
-  where
-    trim = let f = reverse . dropWhile isSpace in f . f
-    mkLine l | (k, '=':v) <- break (=='=') l = Just (splitOn "." (trim k), trim v)
-             | otherwise                       = Nothing
-
--- | inject the environment into the parser
---   the map contains the paths with the value that's passed into the reader if the
---   command line parser gives no result
-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)
-                  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
-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
-
-normalizeName :: String -> String
-normalizeName = map toLower . filter isAlphaNum
-

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/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/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/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,200 +0,0 @@
-{-# LANGUAGE CPP             #-}
-{-# LANGUAGE RecordWildCards             #-}
-module Main (main) where
-
-import           Data.Monoid
-import           Data.Version           (showVersion)
-import           Options.Applicative
-import           System.Exit            (exitFailure)
-
-import           AddHandler             (addHandler)
-import           Devel                  (DevelOpts (..), devel, develSignal)
-import           Keter                  (keter)
-import           Options                (injectDefaults)
-import qualified Paths_yesod_bin
-
-import           HsFile                 (mkHsFile)
-
-data CabalPgm = Cabal | CabalDev deriving (Show, Eq)
-
-data Options = Options
-               { optCabalPgm :: CabalPgm
-               , optVerbose  :: Bool
-               , optCommand  :: Command
-               }
-  deriving (Show, Eq)
-
-data Command = Init [String]
-             | HsFiles
-             | Configure
-             | Build { buildExtraArgs   :: [String] }
-             | Touch
-             | Devel { develSuccessHook :: Maybe String
-                     , develExtraArgs   :: [String]
-                     , develPort        :: Int
-                     , develTlsPort     :: Int
-                     , proxyTimeout     :: Int
-                     , noReverseProxy   :: Bool
-                     , develHost        :: Maybe String
-                     , cert             :: Maybe (FilePath, FilePath)
-                     }
-             | DevelSignal
-             | Test
-             | AddHandler
-                    { addHandlerRoute   :: Maybe String
-                    , addHandlerPattern :: Maybe String
-                    , addHandlerMethods :: [String]
-                    }
-             | Keter
-                    { _keterNoRebuild :: Bool
-                    , _keterNoCopyTo  :: Bool
-                    , _keterBuildArgs :: [String]
-                    }
-             | Version
-  deriving (Show, Eq)
-
-cabalCommand :: Options -> String
-cabalCommand mopt
-  | optCabalPgm mopt == CabalDev = "cabal-dev"
-  | otherwise                    = "cabal"
-
-
-main :: IO ()
-main = do
-  o <- execParser =<< injectDefaults "yesod"
-         [ ("yesod.devel.extracabalarg" , \o args -> o { optCommand =
-                case optCommand o of
-                    d@Devel{} -> d { develExtraArgs = args }
-                    c -> c
-                })
-         , ("yesod.build.extracabalarg" , \o args -> o { optCommand =
-                case optCommand o of
-                    b@Build{} -> b { buildExtraArgs = args }
-                    c -> c
-                })
-         ] optParser'
-  case optCommand o of
-    Init _          -> initErrorMsg
-    HsFiles         -> mkHsFile
-    Configure       -> cabalErrorMsg
-    Build _         -> cabalErrorMsg
-    Touch           -> cabalErrorMsg
-    Keter{..}       -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs
-    Version         -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
-    AddHandler{..}  -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods
-    Test            -> cabalErrorMsg
-    Devel{..}       -> devel DevelOpts
-                             { verbose      = optVerbose o
-                             , successHook  = develSuccessHook
-                             , develPort    = develPort
-                             , develTlsPort = develTlsPort
-                             , proxyTimeout = proxyTimeout
-                             , useReverseProxy = not noReverseProxy
-                             , develHost    = develHost
-                             , cert         = cert
-                             } develExtraArgs
-    DevelSignal     -> develSignal
-  where
-    initErrorMsg = do
-        mapM_ putStrLn
-            [ "The init command has been removed."
-            , "Please use 'stack new <project name> <template>' instead where the"
-            , "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" )
-
-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)
-                            (progDesc "Command no longer available, please use 'stack new'"))
-                      <> command "hsfiles" (info (pure HsFiles)
-                            (progDesc "Create a hsfiles file for the current folder"))
-                      <> command "configure" (info (pure Configure)
-                            (progDesc "DEPRECATED"))
-                      <> command "build"     (info (helper <*> (Build <$> extraCabalArgs))
-                            (progDesc "DEPRECATED"))
-                      <> command "touch"     (info (pure Touch)
-                            (progDesc "DEPRECATED"))
-                      <> command "devel"     (info (helper <*> develOptions)
-                            (progDesc "Run project with the devel server"))
-                      <> command "devel-signal"     (info (helper <*> pure DevelSignal)
-                            (progDesc "Used internally by the devel command"))
-                      <> command "test"      (info (pure Test)
-                            (progDesc "DEPRECATED"))
-                      <> command "add-handler" (info (helper <*> addHandlerOptions)
-                            (progDesc ("Add a new handler and module to the project."
-                            ++ " Interactively asks for input if you do not specify arguments.")))
-                      <> 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
-    <$> 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"
-                            <> help "Run COMMAND after rebuild succeeds")
-                     <*> extraStackArgs
-                     <*> option auto ( long "port" <> short 'p' <> value 3000 <> metavar "N"
-                            <> help "Devel server listening port" )
-                     <*> option auto ( long "tls-port" <> short 'q' <> value 3443 <> 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"
-                            <> help "Host interface to bind to; IP address, '*' for all interfaces, '*4' for IP4, '*6' for IP6")
-                     <*> optional ( (,)
-                            <$> strOption (long "cert" <> metavar "CERT"
-                                   <> help "Path to TLS certificate file, requires that --key is also defined")
-                            <*> strOption (long "key" <> metavar "KEY"
-                                   <> help "Path to TLS key file, requires that --cert is also defined") )
-
-extraStackArgs :: Parser [String]
-extraStackArgs = many (strOption ( long "extra-stack-arg" <> short 'e' <> metavar "ARG"
-                                   <> 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

yesod-bin/refreshing.html

@@ -1,86 +0,0 @@
-<!doctype html>
-<html>
-  <head>
-    <meta charset='utf-8'>
-    <title>Refreshing - Yesod devel</title>
-    <style>
-      body {
-      background: #e6e6e6;
-      color: #444;
-      text-shadow: 1px 1px 1px #ffffff;
-      font-size: 30px;
-      font-family: georgia, serif;
-      }
-      .wrap {
-      margin: auto;
-      width: 25em;
-      }
-      h1 {
-      margin-bottom: 0;
-      }
-      h2 {
-      margin-top: 0;
-      font-size: 1em;
-      font-style: italic;
-      color: #546369;
-      }
-      header {
-      margin-top: 1em;
-      padding-bottom: 0.25em;
-      border-bottom: 1px solid #ccc;
-      color: #1a6e8e;
-      }
-      footer {
-      margin-top: 3em;
-      padding-top: 0.25em;
-      border-top: 1px solid #ccc;
-      color: #666;
-      font-size: 0.8em;
-      }
-      .msgs {
-      font-size: 0.9em;
-      }
-      .msgs p {
-      margin-bottom: 0.5em;
-      }
-      .msgs ul {
-      margin-top: 0;
-      line-height: 1.7em;
-      }
-      .msgs li {
-      padding-left: 0.5em;
-      }
-    </style>
-  </head>
-  <body>
-    <div class="wrap">
-      <header><small>Yesod Devel</small></header>
-      <h1>The application isn’t built</h1>
-      <h2>We’ll keep trying to refresh every second</h2>
-      <div class="msgs">
-        <script> document.getElementsByClassName("msgs")[0].style.display = "none"; </script>
-        <p>Meanwhile, here is a motivational message:</p>
-        <ul>
-          <li>You are a beautiful person making a beautiful web site.</li>
-          <li>Keep going, you’ve nearly fixed the bug!</li>
-          <li>Check your posture, don’t lean over too much.</li>
-          <li>Get a glass of water, keep hydrated.</li>
-        </ul>
-      </div>
-      <script>
-        var msg = document.getElementsByClassName("msgs")[0];
-        var lis = Array.prototype.slice.call(msg.querySelectorAll("li"));
-        lis.forEach(function(li){ li.style.display = "none"; });
-        lis[Math.floor(Math.random() * lis.length)].style.display = "block";
-        msg.style.display = "block";
-      </script>
-      <footer>
-        <small>
-          <script>
-            document.write(new Date())
-          </script>
-        </small>
-      </footer>
-    </div>
-  </body>
-</html>

yesod-bin/update-hsfiles.sh

@@ -1,17 +0,0 @@
-#!/bin/bash -ex
-
-rm -rf yesod-scaffold
-git clone https://github.com/yesodweb/yesod-scaffold yesod-scaffold
-cd yesod-scaffold
-
-for branch in `git branch --no-color -a | grep remotes | grep -v HEAD | grep -v master`
-do
-    git checkout $branch
-    git checkout -b ${branch##*/}
-done
-
-git checkout master
-runghc build.hs
-cp hsfiles/* ../hsfiles
-
-rm -rf yesod-scaffold

yesod-bin/yesod-bin.cabal

@@ -1,77 +0,0 @@
-name:            yesod-bin
-version:         1.6.2.2
-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
-category:        Web, Yesod
-stability:       Stable
-cabal-version:   >= 1.10
-build-type:      Simple
-homepage:        http://www.yesodweb.com/
-
-extra-source-files:
-  README.md
-  ChangeLog.md
-  refreshing.html
-  *.pem
-
-executable             yesod
-    default-language: Haskell2010
-    if os(windows)
-        cpp-options:     -DWINDOWS
-    if os(openbsd)
-        ld-options:      -Wl,-zwxneeded
-
-    build-depends:     base               >= 4.10         && < 5
-                     , Cabal              >= 1.18
-                     , bytestring         >= 0.9.1.4
-                     , conduit            >= 1.3
-                     , conduit-extra      >= 1.3
-                     , containers         >= 0.2
-                     , data-default-class
-                     , directory          >= 1.2.1
-                     , file-embed
-                     , filepath           >= 1.1
-                     , fsnotify
-                     , http-client        >= 0.4.7
-                     , http-client-tls
-                     , http-reverse-proxy >= 0.4
-                     , http-types         >= 0.7
-                     , network            >= 2.5
-                     , optparse-applicative >= 0.11
-                     , process
-                     , project-template   >= 0.1.1
-                     , say
-                     , split              >= 0.2          && < 0.3
-                     , stm
-                     , streaming-commons
-                     , tar                >= 0.4          && < 0.6
-                     , text               >= 0.11
-                     , time               >= 1.1.4
-                     , transformers
-                     , transformers-compat
-                     , unliftio
-                     , unordered-containers
-                     , wai                >= 2.0
-                     , wai-extra
-                     , warp               >= 1.3.7.5
-                     , warp-tls           >= 3.0.1
-                     , yaml               >= 0.8          && < 0.12
-                     , zlib               >= 0.5
-                     , aeson
-
-    ghc-options:       -Wall -threaded -rtsopts
-    main-is:           main.hs
-    other-modules:     Devel
-                       Keter
-                       AddHandler
-                       Paths_yesod_bin
-                       Options
-                       HsFile
-
-source-repository head
-  type:     git
-  location: https://github.com/yesodweb/yesod

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/LICENSE

@@ -1,20 +1,25 @@
-Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
 
-Permission is hereby granted, free of charge, to any person obtaining
-a copy of this software and associated documentation files (the
-"Software"), to deal in the Software without restriction, including
-without limitation the rights to use, copy, modify, merge, publish,
-distribute, sublicense, and/or sell copies of the Software, and to
-permit persons to whom the Software is furnished to do so, subject to
-the following conditions:
+Copyright 2010, Michael Snoyman. All rights reserved.
 
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
 
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

yesod-core/README

@@ -0,0 +1 @@
+Learn more at http://docs.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/Content.hs

@@ -0,0 +1,232 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Content
+    ( -- * Content
+      Content (..)
+    , emptyContent
+    , ToContent (..)
+      -- * Mime types
+      -- ** Data type
+    , ContentType
+    , typeHtml
+    , typePlain
+    , typeJson
+    , typeXml
+    , typeAtom
+    , typeRss
+    , typeJpeg
+    , typePng
+    , typeGif
+    , typeJavascript
+    , typeCss
+    , typeFlv
+    , typeOgv
+    , typeOctet
+      -- * Utilities
+    , simpleContentType
+      -- * Representations
+    , ChooseRep
+    , HasReps (..)
+    , defChooseRep
+      -- ** Specific content types
+    , RepHtml (..)
+    , RepJson (..)
+    , RepHtmlJson (..)
+    , RepPlain (..)
+    , RepXml (..)
+      -- * Utilities
+    , formatW3
+    , formatRFC1123
+    , formatRFC822
+    ) where
+
+import Data.Maybe (mapMaybe)
+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.Time
+import System.Locale
+
+import qualified Data.Text.Encoding
+import qualified Data.Text.Lazy.Encoding
+
+import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
+import Data.Monoid (mempty)
+
+import Text.Hamlet (Html)
+import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
+import Data.String (IsString (fromString))
+import Network.Wai (FilePart)
+import Data.Conduit (Source, Flush)
+
+data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.
+             | ContentSource (Source IO (Flush Builder))
+             | ContentFile FilePath (Maybe FilePart)
+
+-- | Zero-length enumerator.
+emptyContent :: Content
+emptyContent = ContentBuilder mempty $ Just 0
+
+instance IsString Content where
+    fromString = toContent
+
+-- | Anything which can be converted into 'Content'. Most of the time, you will
+-- want to use the 'ContentBuilder' constructor. An easier approach will be to use
+-- a pre-defined 'toContent' function, such as converting your data into a lazy
+-- bytestring and then calling 'toContent' on that.
+--
+-- Please note that the built-in instances for lazy data structures ('String',
+-- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include
+-- the content length for the 'ContentBuilder' constructor.
+class ToContent a where
+    toContent :: a -> Content
+
+instance ToContent Builder where
+    toContent = flip ContentBuilder Nothing
+instance ToContent B.ByteString where
+    toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs
+instance ToContent L.ByteString where
+    toContent = flip ContentBuilder Nothing . fromLazyByteString
+instance ToContent T.Text where
+    toContent = toContent . Data.Text.Encoding.encodeUtf8
+instance ToContent Text where
+    toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8
+instance ToContent String where
+    toContent = toContent . pack
+instance ToContent Html where
+    toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
+
+-- | A function which gives targetted representations of content based on the
+-- content-types the user accepts.
+type ChooseRep =
+    [ContentType] -- ^ list of content-types user accepts, ordered by preference
+ -> IO (ContentType, Content)
+
+-- | Any type which can be converted to representations.
+class HasReps a where
+    chooseRep :: a -> ChooseRep
+
+-- | A helper method for generating 'HasReps' instances.
+--
+-- This function should be given a list of pairs of content type and conversion
+-- functions. If none of the content types match, the first pair is used.
+defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep
+defChooseRep reps a ts = do
+  let (ct, c) =
+        case mapMaybe helper ts of
+            (x:_) -> x
+            [] -> case reps of
+                    [] -> error "Empty reps to defChooseRep"
+                    (x:_) -> x
+  c' <- c a
+  return (ct, c')
+        where
+            helper ct = do
+                c <- lookup ct reps
+                return (ct, c)
+
+instance HasReps ChooseRep where
+    chooseRep = id
+
+instance HasReps () where
+    chooseRep = defChooseRep [(typePlain, const $ return $ toContent B.empty)]
+
+instance HasReps (ContentType, Content) where
+    chooseRep = const . return
+
+instance HasReps [(ContentType, Content)] where
+    chooseRep a cts = return $
+        case filter (\(ct, _) -> go ct `elem` map go cts) a of
+            ((ct, c):_) -> (ct, c)
+            _ -> case a of
+                    (x:_) -> x
+                    _ -> error "chooseRep [(ContentType, Content)] of empty"
+      where
+        go = simpleContentType
+
+newtype RepHtml = RepHtml Content
+instance HasReps RepHtml where
+    chooseRep (RepHtml c) _ = return (typeHtml, c)
+newtype RepJson = RepJson Content
+instance HasReps RepJson where
+    chooseRep (RepJson c) _ = return (typeJson, c)
+data RepHtmlJson = RepHtmlJson Content Content
+instance HasReps RepHtmlJson where
+    chooseRep (RepHtmlJson html json) = chooseRep
+        [ (typeHtml, html)
+        , (typeJson, json)
+        ]
+newtype RepPlain = RepPlain Content
+instance HasReps RepPlain where
+    chooseRep (RepPlain c) _ = return (typePlain, c)
+newtype RepXml = RepXml Content
+instance HasReps RepXml where
+    chooseRep (RepXml c) _ = return (typeXml, c)
+
+type ContentType = B.ByteString -- FIXME Text?
+
+typeHtml :: ContentType
+typeHtml = "text/html; charset=utf-8"
+
+typePlain :: ContentType
+typePlain = "text/plain; charset=utf-8"
+
+typeJson :: ContentType
+typeJson = "application/json; charset=utf-8"
+
+typeXml :: ContentType
+typeXml = "text/xml"
+
+typeAtom :: ContentType
+typeAtom = "application/atom+xml"
+
+typeRss :: ContentType
+typeRss = "application/rss+xml"
+
+typeJpeg :: ContentType
+typeJpeg = "image/jpeg"
+
+typePng :: ContentType
+typePng = "image/png"
+
+typeGif :: ContentType
+typeGif = "image/gif"
+
+typeJavascript :: ContentType
+typeJavascript = "text/javascript; charset=utf-8"
+
+typeCss :: ContentType
+typeCss = "text/css; charset=utf-8"
+
+typeFlv :: ContentType
+typeFlv = "video/x-flv"
+
+typeOgv :: ContentType
+typeOgv = "video/ogg"
+
+typeOctet :: ContentType
+typeOctet = "application/octet-stream"
+
+-- | Removes \"extra\" information at the end of a content type string. In
+-- particular, removes everything after the semicolon, if present.
+--
+-- 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.breakByte 59 -- 59 == ;
+
+-- | Format a 'UTCTime' in W3 format.
+formatW3 :: UTCTime -> T.Text
+formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00"
+
+-- | Format as per RFC 1123.
+formatRFC1123 :: UTCTime -> T.Text
+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"

yesod-core/Yesod/Core.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+module Yesod.Core
+    ( -- * Type classes
+      Yesod (..)
+    , YesodDispatch (..)
+    , RenderRoute (..)
+      -- ** Breadcrumbs
+    , YesodBreadcrumbs (..)
+    , breadcrumbs
+      -- * Types
+    , Approot (..)
+      -- * Utitlities
+    , maybeAuthorized
+    , widgetToPageContent
+      -- * Defaults
+    , defaultErrorHandler
+      -- * Data types
+    , AuthResult (..)
+    , unauthorizedI
+      -- * Logging
+    , LogLevel (..)
+    , formatLogMessage
+    , fileLocationToString
+    , logDebug
+    , logInfo
+    , logWarn
+    , logError
+    , logOther
+      -- * Misc
+    , yesodVersion
+    , yesodRender
+      -- * Re-exports
+    , module Yesod.Content
+    , module Yesod.Dispatch
+    , module Yesod.Handler
+    , module Yesod.Request
+    , module Yesod.Widget
+    , module Yesod.Message
+    ) where
+
+import Yesod.Internal.Core
+import Yesod.Content
+import Yesod.Dispatch
+import Yesod.Handler
+import Yesod.Request
+import Yesod.Widget
+import Yesod.Message
+
+import Language.Haskell.TH.Syntax
+import qualified Language.Haskell.TH.Syntax as TH
+import Data.Text (Text)
+
+logTH :: LogLevel -> Q Exp
+logTH level =
+    [|messageLoggerHandler $(qLocation >>= liftLoc) $(TH.lift level)|]
+  where
+    liftLoc :: Loc -> Q Exp
+    liftLoc (Loc a b c d e) = [|Loc $(TH.lift a) $(TH.lift b) $(TH.lift c) $(TH.lift d) $(TH.lift e)|]
+
+-- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:
+--
+-- > $(logDebug) "This is a debug log message"
+logDebug :: Q Exp
+logDebug = logTH LevelDebug
+
+-- | See 'logDebug'
+logInfo :: Q Exp
+logInfo = logTH LevelInfo
+-- | See 'logDebug'
+logWarn :: Q Exp
+logWarn = logTH LevelWarn
+-- | See 'logDebug'
+logError :: Q Exp
+logError = logTH LevelError
+
+-- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage:
+--
+-- > $(logOther "My new level") "This is a log message"
+logOther :: Text -> Q Exp
+logOther = logTH . LevelOther
+
+-- | Return an 'Unauthorized' value, with the given i18n message.
+unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult
+unauthorizedI msg =do
+    mr <- getMessageRender
+    return $ Unauthorized $ mr msg

yesod-core/Yesod/Dispatch.hs

@@ -0,0 +1,190 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Dispatch
+    ( -- * Quasi-quoted routing
+      parseRoutes
+    , parseRoutesNoCheck
+    , parseRoutesFile
+    , parseRoutesFileNoCheck
+    , mkYesod
+    , mkYesodSub
+      -- ** More fine-grained
+    , mkYesodData
+    , mkYesodSubData
+    , mkYesodDispatch
+    , mkYesodSubDispatch
+      -- ** Path pieces
+    , PathPiece (..)
+    , PathMultiPiece (..)
+    , Texts
+      -- * Convert to WAI
+    , toWaiApp
+    , toWaiAppPlain
+    ) where
+
+import Data.Functor   ((<$>))
+import Prelude hiding (exp)
+import Yesod.Internal.Core
+import Yesod.Handler hiding (lift)
+import Yesod.Widget (GWidget)
+
+import Web.PathPieces
+import Language.Haskell.TH.Syntax
+
+import qualified Network.Wai as W
+import Network.Wai.Middleware.Gzip
+import Network.Wai.Middleware.Autohead
+
+import Data.ByteString.Lazy.Char8 ()
+
+import Web.ClientSession
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
+import Data.Monoid (mappend)
+import qualified Data.ByteString as S
+import qualified Blaze.ByteString.Builder
+import Network.HTTP.Types (status301)
+import Yesod.Routes.TH
+import Yesod.Content (chooseRep)
+import Yesod.Routes.Parse
+
+type Texts = [Text]
+
+-- | 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
+        -> [Resource String]
+        -> Q [Dec]
+mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
+
+-- | Generates URL datatype and site function for the given 'Resource's. This
+-- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter.
+-- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not
+-- executable by itself, but instead provides functionality to
+-- be embedded in other sites.
+mkYesodSub :: String -- ^ name of the argument datatype
+           -> Cxt
+           -> [Resource String]
+           -> Q [Dec]
+mkYesodSub name clazzes =
+    fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
+  where
+    (name':rest) = words name
+
+-- | 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 -> [Resource String] -> Q [Dec]
+mkYesodData name res = mkYesodDataGeneral name [] False res
+
+mkYesodSubData :: String -> Cxt -> [Resource String] -> Q [Dec]
+mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
+
+mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource String] -> Q [Dec]
+mkYesodDataGeneral name clazzes isSub res = do
+    let (name':rest) = words name
+    (x, _) <- mkYesodGeneral name' rest clazzes isSub res
+    let rname = mkName $ "resources" ++ name
+    eres <- lift res
+    let y = [ SigD rname $ ListT `AppT` (ConT ''Resource `AppT` ConT ''String)
+            , FunD rname [Clause [] (NormalB eres) []]
+            ]
+    return $ x ++ y
+
+-- | See 'mkYesodData'.
+mkYesodDispatch :: String -> [Resource String] -> Q [Dec]
+mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
+
+mkYesodSubDispatch :: String -> Cxt -> [Resource String] -> Q [Dec]
+mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True 
+  where (name':rest) = words name
+
+mkYesodGeneral :: String -- ^ foundation type
+               -> [String]
+               -> Cxt -- ^ classes
+               -> Bool -- ^ is subsite?
+               -> [Resource String]
+               -> Q ([Dec], [Dec])
+mkYesodGeneral name args clazzes isSub resS = do
+    let args' = map mkName args
+        arg = foldl AppT (ConT name') $ map VarT args'
+    let res = map (fmap parseType) resS
+    renderRouteDec <- mkRenderRouteInstance arg res
+
+    disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res
+    let master = mkName "master"
+    let ctx = if isSub
+                then ClassP (mkName "Yesod") [VarT master] : clazzes
+                else []
+    let ytyp = if isSub
+                then ConT ''YesodDispatch `AppT` arg `AppT` VarT master
+                else ConT ''YesodDispatch `AppT` arg `AppT` arg
+    let yesodDispatch' =
+            InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]]
+
+    return (renderRouteDec : masterTypSyns, [yesodDispatch'])
+  where
+    name' = mkName name
+    masterTypSyns
+        | isSub = []
+        | otherwise =
+            [ TySynD
+                (mkName "Handler")
+                []
+                (ConT ''GHandler `AppT` ConT name' `AppT` ConT name')
+            , TySynD
+                (mkName "Widget")
+                []
+                (ConT ''GWidget `AppT` ConT name' `AppT` ConT name' `AppT` TupleT 0)
+            ]
+
+-- | Convert the given argument into a WAI application, executable with any WAI
+-- handler. This is the same as 'toWaiAppPlain', except it includes two
+-- middlewares: GZIP compression and autohead. This is the
+-- recommended approach for most users.
+toWaiApp :: ( Yesod master
+            , YesodDispatch master master
+            ) => master -> IO W.Application
+toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y
+
+-- | Convert the given argument into a WAI application, executable with any WAI
+-- handler. This differs from 'toWaiApp' in that it uses no middlewares.
+toWaiAppPlain :: ( Yesod master
+                 , YesodDispatch master master
+                 ) => master -> IO W.Application
+toWaiAppPlain a = toWaiApp' a <$> encryptKey a
+
+
+toWaiApp' :: ( Yesod master
+             , YesodDispatch master master
+             )
+          => master
+          -> Maybe Key
+          -> W.Application
+toWaiApp' y key' env =
+    case cleanPath y $ W.pathInfo env of
+        Left pieces -> sendRedirect y pieces env
+        Right pieces ->
+            yesodDispatch y y id app404 handler405 method pieces key' env
+  where
+    app404 = yesodRunner notFound y y Nothing id
+    handler405 route = yesodRunner badMethod y y (Just route) id
+    method = decodeUtf8With lenientDecode $ W.requestMethod env
+
+sendRedirect :: Yesod master => master -> [Text] -> W.Application
+sendRedirect y segments' env =
+     return $ W.responseLBS status301
+            [ ("Content-Type", "text/plain")
+            , ("Location", Blaze.ByteString.Builder.toByteString dest')
+            ] "Redirecting"
+  where
+    dest = joinPath y (resolveApproot y env) segments' []
+    dest' =
+        if S.null (W.rawQueryString env)
+            then dest
+            else (dest `mappend`
+                 Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))

yesod-core/Yesod/Handler.hs

@@ -0,0 +1,933 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+---------------------------------------------------------
+--
+-- Module        : Yesod.Handler
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- Stability     : stable
+-- Portability   : portable
+--
+-- Define Handler stuff.
+--
+---------------------------------------------------------
+module Yesod.Handler
+    ( -- * Type families
+      YesodSubRoute (..)
+      -- * Handler monad
+    , GHandler
+      -- ** Read information from handler
+    , getYesod
+    , getYesodSub
+    , getUrlRender
+    , getUrlRenderParams
+    , getCurrentRoute
+    , getRouteToMaster
+    , getRequest
+    , waiRequest
+    , runRequestBody
+      -- * Special responses
+      -- ** Redirecting
+    , RedirectUrl (..)
+    , redirect
+    , redirectWith
+    , redirectToPost
+      -- ** Errors
+    , notFound
+    , badMethod
+    , permissionDenied
+    , permissionDeniedI
+    , invalidArgs
+    , invalidArgsI
+      -- ** Short-circuit responses.
+    , sendFile
+    , sendFilePart
+    , sendResponse
+    , sendResponseStatus
+    , sendResponseCreated
+    , sendWaiResponse
+      -- * Setting headers
+    , setCookie
+    , getExpires
+    , deleteCookie
+    , setHeader
+    , setLanguage
+      -- ** Content caching and expiration
+    , cacheSeconds
+    , neverExpires
+    , alreadyExpired
+    , expiresAt
+      -- * Session
+    , SessionMap
+    , lookupSession
+    , lookupSessionBS
+    , getSession
+    , setSession
+    , setSessionBS
+    , deleteSession
+      -- ** Ultimate destination
+    , setUltDest
+    , setUltDestCurrent
+    , setUltDestReferer
+    , redirectUltDest
+    , clearUltDest
+      -- ** Messages
+    , setMessage
+    , setMessageI
+    , getMessage
+      -- * Helpers for specific content
+      -- ** Hamlet
+    , hamletToContent
+    , hamletToRepHtml
+      -- ** Misc
+    , newIdent
+      -- * Lifting
+    , MonadLift (..)
+      -- * i18n
+    , getMessageRender
+      -- * Per-request caching
+    , CacheKey
+    , mkCacheKey
+    , cacheLookup
+    , cacheInsert
+    , cacheDelete
+      -- * Internal Yesod
+    , runHandler
+    , YesodApp (..)
+    , runSubsiteGetter
+    , toMasterHandler
+    , toMasterHandlerDyn
+    , toMasterHandlerMaybe
+    , localNoCurrent
+    , HandlerData
+    , ErrorResponse (..)
+    , YesodAppResult (..)
+    , handlerToYAR
+    , yarToResponse
+    , headerToPair
+    ) where
+
+import Prelude hiding (catch)
+import Yesod.Internal.Request
+import Yesod.Internal
+import Data.Time (UTCTime, getCurrentTime, addUTCTime)
+
+import Control.Exception hiding (Handler, catch, finally)
+import Control.Applicative
+
+import Control.Monad (liftM)
+
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class (MonadTrans)
+import qualified Control.Monad.Trans.Class
+
+import System.IO
+import qualified Network.Wai as W
+import qualified Network.HTTP.Types as H
+
+import Text.Hamlet
+import qualified Text.Blaze.Renderer.Text
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
+import qualified Data.Text.Lazy as TL
+
+import qualified Data.Map as Map
+import qualified Data.ByteString as S
+import Network.Wai.Parse (parseHttpAccept)
+
+import Yesod.Content
+import Data.Maybe (fromMaybe)
+import Web.Cookie (SetCookie (..), renderSetCookie)
+import Control.Arrow ((***))
+import qualified Network.Wai.Parse as NWP
+import Data.Monoid (mappend, mempty, Endo (..))
+import qualified Data.ByteString.Char8 as S8
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+import Blaze.ByteString.Builder (toByteString)
+import Data.Text (Text)
+import Yesod.Message (RenderMessage (..))
+
+import Text.Blaze (toHtml, preEscapedText)
+
+import qualified Yesod.Internal.Cache as Cache
+import Yesod.Internal.Cache (mkCacheKey, CacheKey)
+import Data.Typeable (Typeable)
+import qualified Data.IORef as I
+import Control.Monad.Trans.Resource
+import Control.Exception.Lifted (catch)
+import Control.Monad.Trans.Control
+import Control.Monad.Base
+import Yesod.Routes.Class
+
+class YesodSubRoute s y where
+    fromSubRoute :: s -> y -> Route s -> Route y
+
+data HandlerData sub master = HandlerData
+    { handlerRequest  :: Request
+    , handlerSub      :: sub
+    , handlerMaster   :: master
+    , handlerRoute    :: Maybe (Route sub)
+    , handlerRender   :: Route master -> [(Text, Text)] -> Text
+    , handlerToMaster :: Route sub -> Route master
+    , handlerState    :: I.IORef GHState
+    }
+
+handlerSubData :: (Route sub -> Route master)
+               -> (master -> sub)
+               -> Route sub
+               -> HandlerData oldSub master
+               -> HandlerData sub master
+handlerSubData tm ts = handlerSubDataMaybe tm ts . Just
+
+handlerSubDataMaybe :: (Route sub -> Route master)
+                    -> (master -> sub)
+                    -> Maybe (Route sub)
+                    -> HandlerData oldSub master
+                    -> HandlerData sub master
+handlerSubDataMaybe tm ts route hd = hd
+    { handlerSub = ts $ handlerMaster hd
+    , handlerToMaster = tm
+    , handlerRoute = route
+    }
+
+get :: GHandler sub master GHState
+get = do
+    hd <- ask
+    liftIO $ I.readIORef $ handlerState hd
+
+put :: GHState -> GHandler sub master ()
+put g = do
+    hd <- ask
+    liftIO $ I.writeIORef (handlerState hd) g
+
+modify :: (GHState -> GHState) -> GHandler sub master ()
+modify f = do
+    hd <- ask
+    liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ())
+
+tell :: Endo [Header] -> GHandler sub master ()
+tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
+
+-- | Used internally for promoting subsite handler functions to master site
+-- handler functions. Should not be needed by users.
+toMasterHandler :: (Route sub -> Route master)
+                -> (master -> sub)
+                -> Route sub
+                -> GHandler sub master a
+                -> GHandler sub' master a
+toMasterHandler tm ts route = local (handlerSubData tm ts route)
+
+-- | FIXME do we need this?
+toMasterHandlerDyn :: (Route sub -> Route master)
+                   -> GHandler sub' master sub
+                   -> Route sub
+                   -> GHandler sub master a
+                   -> GHandler sub' master a
+toMasterHandlerDyn tm getSub route h = do
+    sub <- getSub
+    local (handlerSubData tm (const sub) route) h
+
+class SubsiteGetter g m s | g -> s where
+  runSubsiteGetter :: g -> m s
+
+instance (master ~ master'
+         ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where
+  runSubsiteGetter getter = getter <$> getYesod
+
+instance (anySub ~ anySub'
+         ,master ~ master'
+         ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where
+  runSubsiteGetter = id
+
+toMasterHandlerMaybe :: (Route sub -> Route master)
+                     -> (master -> sub)
+                     -> Maybe (Route sub)
+                     -> GHandler sub master a
+                     -> GHandler sub' master a
+toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route)
+
+-- | A generic handler monad, which can have a different subsite and master
+-- site. We define a newtype for better error message.
+newtype GHandler sub master a = GHandler
+    { unGHandler :: HandlerData sub master -> ResourceT IO a
+    }
+
+data GHState = GHState
+    { ghsSession :: SessionMap
+    , ghsRBC :: Maybe RequestBodyContents
+    , ghsIdent :: Int
+    , ghsCache :: Cache.Cache
+    , ghsHeaders :: Endo [Header]
+    }
+
+type SessionMap = Map.Map Text S.ByteString
+
+-- | 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 'GHandler' monad and template haskell code should hide it away.
+newtype YesodApp = YesodApp
+    { unYesodApp
+    :: (ErrorResponse -> YesodApp)
+    -> Request
+    -> [ContentType]
+    -> SessionMap
+    -> ResourceT IO YesodAppResult
+    }
+
+data YesodAppResult
+    = YARWai W.Response
+    | YARPlain H.Status [Header] ContentType Content SessionMap
+
+data HandlerContents =
+      HCContent H.Status ChooseRep
+    | HCError ErrorResponse
+    | HCSendFile ContentType FilePath (Maybe W.FilePart) -- FIXME replace FilePath with opaque type from system-filepath?
+    | HCRedirect H.Status Text
+    | HCCreated Text
+    | HCWai W.Response
+    deriving Typeable
+
+instance Show HandlerContents where
+    show _ = "Cannot show a HandlerContents"
+instance Exception HandlerContents
+
+getRequest :: GHandler s m Request
+getRequest = handlerRequest `liftM` ask
+
+hcError :: ErrorResponse -> GHandler sub master a
+hcError = liftIO . throwIO . HCError
+
+runRequestBody :: GHandler s m RequestBodyContents
+runRequestBody = do
+    x <- get
+    case ghsRBC x of
+        Just rbc -> return rbc
+        Nothing -> do
+            rr <- waiRequest
+            rbc <- lift $ rbHelper rr
+            put x { ghsRBC = Just rbc }
+            return rbc
+
+rbHelper :: W.Request -> ResourceT IO RequestBodyContents
+rbHelper req =
+    (map fix1 *** map fix2) <$> (NWP.parseRequestBody NWP.lbsBackEnd req)
+  where
+    fix1 = go *** go
+    fix2 (x, NWP.FileInfo a b c) =
+        (go x, FileInfo (go a) (go b) c)
+    go = decodeUtf8With lenientDecode
+
+-- | Get the sub application argument.
+getYesodSub :: GHandler sub master sub
+getYesodSub = handlerSub `liftM` ask
+
+-- | Get the master site appliation argument.
+getYesod :: GHandler sub master master
+getYesod = handlerMaster `liftM` ask
+
+-- | Get the URL rendering function.
+getUrlRender :: GHandler sub master (Route master -> Text)
+getUrlRender = do
+    x <- handlerRender `liftM` ask
+    return $ flip x []
+
+-- | The URL rendering function with query-string parameters.
+getUrlRenderParams
+    :: GHandler sub master (Route master -> [(Text, Text)] -> Text)
+getUrlRenderParams = handlerRender `liftM` ask
+
+-- | Get the route requested by the user. If this is a 404 response- where the
+-- user requested an invalid route- this function will return 'Nothing'.
+getCurrentRoute :: GHandler sub master (Maybe (Route sub))
+getCurrentRoute = handlerRoute `liftM` ask
+
+-- | Get the function to promote a route for a subsite to a route for the
+-- master site.
+getRouteToMaster :: GHandler sub master (Route sub -> Route master)
+getRouteToMaster = handlerToMaster `liftM` ask
+
+-- | Function used internally by Yesod in the process of converting a
+-- 'GHandler' into an 'W.Application'. Should not be needed by users.
+runHandler :: HasReps c
+           => GHandler sub master c
+           -> (Route master -> [(Text, Text)] -> Text)
+           -> Maybe (Route sub)
+           -> (Route sub -> Route master)
+           -> master
+           -> sub
+           -> YesodApp
+runHandler handler mrender sroute tomr master sub =
+  YesodApp $ \eh rr cts initSession -> do
+    let toErrorHandler e =
+            case fromException e of
+                Just x -> x
+                Nothing -> InternalError $ T.pack $ show e
+    istate <- liftIO $ I.newIORef GHState
+        { ghsSession = initSession
+        , ghsRBC = Nothing
+        , ghsIdent = 1
+        , ghsCache = mempty
+        , ghsHeaders = mempty
+        }
+    let hd = HandlerData
+            { handlerRequest = rr
+            , handlerSub = sub
+            , handlerMaster = master
+            , handlerRoute = sroute
+            , handlerRender = mrender
+            , handlerToMaster = tomr
+            , handlerState = istate
+            }
+    contents' <- catch (fmap Right $ unGHandler handler hd)
+        (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
+                      $ fromException e)
+    state <- liftIO $ I.readIORef istate
+    let finalSession = ghsSession state
+    let headers = ghsHeaders state
+    let contents = either id (HCContent H.status200 . chooseRep) contents'
+    let handleError e = do
+            yar <- unYesodApp (eh e) safeEh rr cts finalSession
+            case yar of
+                YARPlain _ hs ct c sess ->
+                    let hs' = appEndo headers hs
+                     in return $ YARPlain (getStatus e) hs' ct c sess
+                YARWai _ -> return yar
+    let sendFile' ct fp p =
+            return $ YARPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
+    case contents of
+        HCContent status a -> do
+            (ct, c) <- liftIO $ a cts
+            return $ YARPlain status (appEndo headers []) ct c finalSession
+        HCError e -> handleError e
+        HCRedirect status loc -> do
+            let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
+            return $ YARPlain
+                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) : appEndo headers []
+            return $ YARPlain
+                H.status201
+                hs
+                typePlain
+                emptyContent
+                finalSession
+        HCWai r -> return $ YARWai r
+
+safeEh :: ErrorResponse -> YesodApp
+safeEh er = YesodApp $ \_ _ _ session -> do
+    liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
+    return $ YARPlain
+        H.status500
+        []
+        typePlain
+        (toContent ("Internal Server Error" :: S.ByteString))
+        session
+
+-- | Redirect to the given route.
+-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
+-- This is the appropriate choice for a get-following-post
+-- technique, which should be the usual use case.
+--
+-- If you want direct control of the final status code, or need a different
+-- status code, please use 'redirectWith'.
+redirect :: RedirectUrl master url => url -> GHandler sub master a
+redirect url = do
+    req <- waiRequest
+    let status =
+            if W.httpVersion req == H.http11
+                then H.status303
+                else H.status302
+    redirectWith status url
+
+-- | Redirect to the given URL with the specified status code.
+redirectWith :: RedirectUrl master url => H.Status -> url -> GHandler sub master a
+redirectWith status url = do
+    urlText <- toTextUrl url
+    liftIO $ throwIO $ HCRedirect status urlText
+
+ultDestKey :: Text
+ultDestKey = "_ULT"
+
+-- | Sets the ultimate destination variable to the given route.
+--
+-- An ultimate destination is stored in the user session and can be loaded
+-- later by 'redirectUltDest'.
+setUltDest :: RedirectUrl master url => url -> GHandler sub master ()
+setUltDest url = do
+    urlText <- toTextUrl url
+    setSession ultDestKey urlText
+
+-- | Same as 'setUltDest', but uses the current page.
+--
+-- If this is a 404 handler, there is no current page, and then this call does
+-- nothing.
+setUltDestCurrent :: GHandler sub master ()
+setUltDestCurrent = do
+    route <- getCurrentRoute
+    case route of
+        Nothing -> return ()
+        Just r -> do
+            tm <- getRouteToMaster
+            gets' <- reqGetParams `liftM` handlerRequest `liftM` ask
+            setUltDest (tm r, gets')
+
+-- | Sets the ultimate destination to the referer request header, if present.
+--
+-- This function will not overwrite an existing ultdest.
+setUltDestReferer :: GHandler sub master ()
+setUltDestReferer = do
+    mdest <- lookupSession ultDestKey
+    maybe
+        (waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)
+        (const $ return ())
+        mdest
+  where
+    setUltDestBS = setUltDest . T.pack . S8.unpack
+
+-- | Redirect to the ultimate destination in the user's session. Clear the
+-- value from the session.
+--
+-- The ultimate destination is set with 'setUltDest'.
+--
+-- This function uses 'redirect', and thus will perform a temporary redirect to
+-- a GET request.
+redirectUltDest :: RedirectUrl master url
+                => url -- ^ default destination if nothing in session
+                -> GHandler sub master a
+redirectUltDest def = do
+    mdest <- lookupSession ultDestKey
+    deleteSession ultDestKey
+    maybe (redirect def) redirect mdest
+
+-- | Remove a previously set ultimate destination. See 'setUltDest'.
+clearUltDest :: GHandler sub master ()
+clearUltDest = deleteSession ultDestKey
+
+msgKey :: Text
+msgKey = "_MSG"
+
+-- | Sets a message in the user's session.
+--
+-- See 'getMessage'.
+setMessage :: Html -> GHandler sub master ()
+setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
+
+-- | Sets a message in the user's session.
+--
+-- See 'getMessage'.
+setMessageI :: (RenderMessage y msg) => msg -> GHandler sub y ()
+setMessageI msg = do
+    mr <- getMessageRender
+    setMessage $ toHtml $ mr msg
+
+-- | Gets the message in the user's session, if available, and then clears the
+-- variable.
+--
+-- See 'setMessage'.
+getMessage :: GHandler sub master (Maybe Html)
+getMessage = do
+    mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
+    deleteSession msgKey
+    return mmsg
+
+-- | Bypass remaining handler code and output the given file.
+--
+-- For some backends, this is more efficient than reading in the file to
+-- memory, since they can optimize file sending via a system call to sendfile.
+sendFile :: ContentType -> FilePath -> GHandler sub master a
+sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing
+
+-- | Same as 'sendFile', but only sends part of a file.
+sendFilePart :: ContentType
+             -> FilePath
+             -> Integer -- ^ offset
+             -> Integer -- ^ count
+             -> GHandler sub master a
+sendFilePart ct fp off count =
+    liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count
+
+-- | Bypass remaining handler code and output the given content with a 200
+-- status code.
+sendResponse :: HasReps c => c -> GHandler sub master a
+sendResponse = liftIO . throwIO . HCContent H.status200
+             . chooseRep
+
+-- | Bypass remaining handler code and output the given content with the given
+-- status code.
+sendResponseStatus :: HasReps c => H.Status -> c -> GHandler s m a
+sendResponseStatus s = liftIO . throwIO . HCContent s
+                     . chooseRep
+
+-- | Send a 201 "Created" response with the given route as the Location
+-- response header.
+sendResponseCreated :: Route m -> GHandler s m a
+sendResponseCreated url = do
+    r <- getUrlRender
+    liftIO . throwIO $ HCCreated $ r url
+
+-- | Send a 'W.Response'. Please note: this function is rarely
+-- necessary, and will /disregard/ any changes to response headers and session
+-- that you have already specified. This function short-circuits. It should be
+-- considered only for very specific needs. If you are not sure if you need it,
+-- you don't.
+sendWaiResponse :: W.Response -> GHandler s m b
+sendWaiResponse = liftIO . throwIO . HCWai
+
+-- | Return a 404 not found page. Also denotes no handler available.
+notFound :: GHandler sub master a
+notFound = hcError NotFound
+
+-- | Return a 405 method not supported page.
+badMethod :: GHandler sub master a
+badMethod = do
+    w <- waiRequest
+    hcError $ BadMethod $ W.requestMethod w
+
+-- | Return a 403 permission denied page.
+permissionDenied :: Text -> GHandler sub master a
+permissionDenied = hcError . PermissionDenied
+
+-- | Return a 403 permission denied page.
+permissionDeniedI :: RenderMessage master msg => msg -> GHandler sub master a
+permissionDeniedI msg = do
+    mr <- getMessageRender
+    permissionDenied $ mr msg
+
+-- | Return a 400 invalid arguments page.
+invalidArgs :: [Text] -> GHandler sub master a
+invalidArgs = hcError . InvalidArgs
+
+-- | Return a 400 invalid arguments page.
+invalidArgsI :: RenderMessage y msg => [msg] -> GHandler s y a
+invalidArgsI msg = do
+    mr <- getMessageRender
+    invalidArgs $ map mr msg
+
+------- Headers
+-- | Set the cookie on the client.
+
+setCookie :: SetCookie
+          -> GHandler sub master ()
+setCookie = addHeader . AddCookie
+
+-- | Helper function for setCookieExpires value
+getExpires :: Int -- ^ minutes
+          -> IO UTCTime
+getExpires m = do
+    now <- liftIO getCurrentTime
+    return $ fromIntegral (m * 60) `addUTCTime` now
+
+
+-- | Unset the cookie on the client.
+--
+-- Note: although the value used for key and path is 'Text', you should only
+-- use ASCII values to be HTTP compliant.
+deleteCookie :: Text -- ^ key 
+             -> Text -- ^ path
+             -> GHandler sub master ()
+deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8
+
+
+-- | Set the language in the user session. Will show up in 'languages' on the
+-- next request.
+setLanguage :: Text -> GHandler sub master ()
+setLanguage = setSession langKey
+
+-- | Set an arbitrary response header.
+--
+-- Note that, while the data type used here is 'Text', you must provide only
+-- ASCII value to be HTTP compliant.
+setHeader :: Text -> Text -> GHandler sub master ()
+setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8
+
+-- | Set the Cache-Control header to indicate this response should be cached
+-- for the given number of seconds.
+cacheSeconds :: Int -> GHandler s m ()
+cacheSeconds i = setHeader "Cache-Control" $ T.concat
+    [ "max-age="
+    , T.pack $ show i
+    , ", public"
+    ]
+
+-- | Set the Expires header to some date in 2037. In other words, this content
+-- is never (realistically) expired.
+neverExpires :: GHandler s m ()
+neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
+
+-- | Set an Expires header in the past, meaning this content should not be
+-- cached.
+alreadyExpired :: GHandler s m ()
+alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
+
+-- | Set an Expires header to the given date.
+expiresAt :: UTCTime -> GHandler s m ()
+expiresAt = setHeader "Expires" . formatRFC1123
+
+-- | Set a variable in the user's session.
+--
+-- The session is handled by the clientsession package: it sets an encrypted
+-- and hashed cookie on the client. This ensures that all data is secure and
+-- not tampered with.
+setSession :: Text -- ^ key
+           -> Text -- ^ value
+           -> GHandler sub master ()
+setSession k = setSessionBS k . encodeUtf8
+
+-- | Same as 'setSession', but uses binary data for the value.
+setSessionBS :: Text
+             -> S.ByteString
+             -> GHandler sub master ()
+setSessionBS k = modify . modSession . Map.insert k
+
+-- | Unsets a session variable. See 'setSession'.
+deleteSession :: Text -> GHandler sub master ()
+deleteSession = modify . modSession . Map.delete
+
+modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
+modSession f x = x { ghsSession = f $ ghsSession x }
+
+-- | Internal use only, not to be confused with 'setHeader'.
+addHeader :: Header -> GHandler sub master ()
+addHeader = tell . Endo . (:)
+
+getStatus :: ErrorResponse -> H.Status
+getStatus NotFound = H.status404
+getStatus (InternalError _) = H.status500
+getStatus (InvalidArgs _) = H.status400
+getStatus (PermissionDenied _) = H.status403
+getStatus (BadMethod _) = H.status405
+
+-- | Some value which can be turned into a URL for redirects.
+class RedirectUrl master a where
+    -- | Converts the value to the URL and a list of query-string parameters.
+    toTextUrl :: a -> GHandler sub master Text
+
+instance RedirectUrl master Text where
+    toTextUrl = return
+
+instance RedirectUrl master String where
+    toTextUrl = toTextUrl . T.pack
+
+instance RedirectUrl master (Route master) where
+    toTextUrl url = do
+        r <- getUrlRender
+        return $ r url
+
+instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where
+    toTextUrl (url, params) = do
+        r <- getUrlRenderParams
+        return $ r url params
+
+localNoCurrent :: GHandler s m a -> GHandler s m a
+localNoCurrent =
+    local (\hd -> hd { handlerRoute = Nothing })
+
+-- | Lookup for session data.
+lookupSession :: Text -> GHandler s m (Maybe Text)
+lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS
+
+-- | Lookup for session data in binary format.
+lookupSessionBS :: Text -> GHandler s m (Maybe S.ByteString)
+lookupSessionBS n = do
+    m <- liftM ghsSession get
+    return $ Map.lookup n m
+
+-- | Get all session variables.
+getSession :: GHandler sub master SessionMap
+getSession = liftM ghsSession get
+
+handlerToYAR :: (HasReps a, HasReps b)
+             => master -- ^ master site foundation
+             -> sub    -- ^ sub site foundation
+             -> (Route sub -> Route master)
+             -> (Route master -> [(Text, Text)] -> Text) -- route renderer
+             -> (ErrorResponse -> GHandler sub master a)
+             -> Request
+             -> Maybe (Route sub)
+             -> SessionMap
+             -> GHandler sub master b
+             -> ResourceT IO YesodAppResult
+handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
+    unYesodApp ya eh' rr types sessionMap
+  where
+    ya = runHandler h render murl toMasterRoute y s
+    eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s
+    types = httpAccept $ reqWaiRequest rr
+    errorHandler' = localNoCurrent . errorHandler
+
+type HeaderRenderer = [Header]
+                   -> ContentType
+                   -> SessionMap
+                   -> [(CI H.Ascii, H.Ascii)]
+
+yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response
+yarToResponse _ (YARWai a) = a
+yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
+    case c of
+        ContentBuilder b mlen ->
+            let hs' = maybe finalHeaders finalHeaders' mlen
+             in W.ResponseBuilder s hs' b
+        ContentFile fp p -> W.ResponseFile s finalHeaders fp p
+        ContentSource body -> W.ResponseSource s finalHeaders body
+  where
+    finalHeaders = renderHeaders hs ct sessionFinal
+    finalHeaders' len = ("Content-Length", S8.pack $ show len)
+                      : finalHeaders
+
+
+httpAccept :: W.Request -> [ContentType]
+httpAccept = parseHttpAccept
+           . fromMaybe mempty
+           . lookup "Accept"
+           . W.requestHeaders
+
+-- | Convert Header to a key/value pair.
+headerToPair :: Header
+             -> (CI H.Ascii, H.Ascii)
+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)
+
+-- | Get a unique identifier.
+newIdent :: GHandler sub master Text
+newIdent = do
+    x <- get
+    let i' = ghsIdent x + 1
+    put x { ghsIdent = i' }
+    return $ T.pack $ 'h' : show i'
+
+-- | Redirect to a POST resource.
+--
+-- This is not technically a redirect; instead, it returns an HTML page with a
+-- POST form, and some Javascript to automatically submit the form. This can be
+-- useful when you need to post a plain link somewhere that needs to cause
+-- changes on the server.
+redirectToPost :: RedirectUrl master url => url -> GHandler sub master a
+redirectToPost url = do
+    urlText <- toTextUrl url
+    hamletToRepHtml
+#if GHC7
+            [hamlet|
+#else
+            [$hamlet|
+#endif
+\<!DOCTYPE html>
+
+<html>
+    <head>
+        <title>Redirecting...
+    <body onload="document.getElementById('form').submit()">
+        <form id="form" method="post" action=#{urlText}>
+            <noscript>
+                <p>Javascript has been disabled; please click on the button below to be redirected.
+            <input type="submit" value="Continue">
+|] >>= sendResponse
+
+-- | Converts the given Hamlet template into 'Content', which can be used in a
+-- Yesod 'Response'.
+hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content
+hamletToContent h = do
+    render <- getUrlRenderParams
+    return $ toContent $ h render
+
+-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
+hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml
+hamletToRepHtml = liftM RepHtml . hamletToContent
+
+-- | Get the request\'s 'W.Request' value.
+waiRequest :: GHandler sub master W.Request
+waiRequest = reqWaiRequest `liftM` getRequest
+
+getMessageRender :: RenderMessage master message => GHandler s master (message -> Text)
+getMessageRender = do
+    m <- getYesod
+    l <- reqLangs `liftM` getRequest
+    return $ renderMessage m l
+
+cacheLookup :: CacheKey a -> GHandler sub master (Maybe a)
+cacheLookup k = do
+    gs <- get
+    return $ Cache.lookup k $ ghsCache gs
+
+cacheInsert :: CacheKey a -> a -> GHandler sub master ()
+cacheInsert k v = modify $ \gs ->
+    gs { ghsCache = Cache.insert k v $ ghsCache gs }
+
+cacheDelete :: CacheKey a -> GHandler sub master ()
+cacheDelete k = modify $ \gs ->
+    gs { ghsCache = Cache.delete k $ ghsCache gs }
+
+ask :: GHandler sub master (HandlerData sub master)
+ask = GHandler return
+
+local :: (HandlerData sub' master' -> HandlerData sub master)
+      -> GHandler sub master a
+      -> GHandler sub' master' a
+local f (GHandler x) = GHandler $ \r -> x $ f r
+
+-- | The standard @MonadTrans@ class only allows lifting for monad
+-- transformers. While @GHandler@ and @GWidget@ should allow lifting, their
+-- types do not express that they actually are transformers. This replacement
+-- class accounts for this.
+class MonadLift base m | m -> base where
+    lift :: base a -> m a
+instance (Monad m, MonadTrans t) => MonadLift m (t m) where
+    lift = Control.Monad.Trans.Class.lift
+instance MonadLift (ResourceT IO) (GHandler sub master) where
+    lift = GHandler . const
+
+-- Instances for GHandler
+instance Functor (GHandler sub master) where
+    fmap f (GHandler x) = GHandler $ \r -> fmap f (x r)
+instance Applicative (GHandler sub master) where
+    pure = GHandler . const . pure
+    GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r
+instance Monad (GHandler sub master) where
+    return = pure
+    GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r
+instance MonadIO (GHandler sub master) where
+    liftIO = GHandler . const . lift
+instance MonadBase IO (GHandler sub master) where
+    liftBase = GHandler . const . lift
+instance MonadBaseControl IO (GHandler sub master) where
+    data StM (GHandler sub master) a = StH (StM (ResourceT IO) a)
+    liftBaseWith f = GHandler $ \reader ->
+        liftBaseWith $ \runInBase ->
+            f $ liftM StH . runInBase . (\(GHandler r) -> r reader)
+    restoreM (StH base) = GHandler $ const $ restoreM base
+
+instance Resource (GHandler sub master) where
+    type Base (GHandler sub master) = IO
+    resourceLiftBase = liftIO
+    resourceBracket_ a b c = control $ \run -> resourceBracket_ a b (run c)
+instance ResourceUnsafeIO (GHandler sub master) where
+    unsafeFromIO = liftIO
+instance ResourceThrow (GHandler sub master) where
+    resourceThrow = liftIO . throwIO
+instance ResourceIO (GHandler sub master)

yesod-core/Yesod/Internal.hs

@@ -0,0 +1,130 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+-- | Normal users should never need access to these.
+module Yesod.Internal
+    ( -- * Error responses
+      ErrorResponse (..)
+      -- * Header
+    , Header (..)
+      -- * Cookie names
+    , langKey
+      -- * Widgets
+    , GWData (..)
+    , Location (..)
+    , UniqueList (..)
+    , Script (..)
+    , Stylesheet (..)
+    , Title (..)
+    , Head (..)
+    , Body (..)
+    , locationToHtmlUrl
+    , runUniqueList
+    , toUnique
+      -- * Names
+    , sessionName
+    , nonceKey
+    ) where
+
+import Text.Hamlet (HtmlUrl, hamlet, Html)
+import Text.Julius (JavascriptUrl)
+import Data.Monoid (Monoid (..), Last)
+import Data.List (nub)
+
+import Data.Text (Text)
+
+import Data.Typeable (Typeable)
+import Control.Exception (Exception)
+
+import qualified Network.HTTP.Types as H
+import Data.String (IsString)
+import qualified Data.Map as Map
+import Data.Text.Lazy.Builder (Builder)
+import Network.HTTP.Types (Ascii)
+import Web.Cookie (SetCookie (..))
+
+#if GHC7
+#define HAMLET hamlet
+#else
+#define HAMLET $hamlet
+#endif
+
+-- | 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]
+    | PermissionDenied Text
+    | BadMethod H.Method
+    deriving (Show, Eq, Typeable)
+instance Exception ErrorResponse
+
+----- header stuff
+-- | Headers to be added to a 'Result'.
+data Header =
+    AddCookie SetCookie
+    | DeleteCookie Ascii Ascii
+    | Header Ascii Ascii
+    deriving (Eq, Show)
+
+langKey :: IsString a => a
+langKey = "_LANG"
+
+data Location url = Local url | Remote Text
+    deriving (Show, Eq)
+locationToHtmlUrl :: Location url -> HtmlUrl url
+locationToHtmlUrl (Local url) = [HAMLET|\@{url}
+|]
+locationToHtmlUrl (Remote s) = [HAMLET|\#{s}
+|]
+
+newtype UniqueList x = UniqueList ([x] -> [x])
+instance Monoid (UniqueList x) where
+    mempty = UniqueList id
+    UniqueList x `mappend` UniqueList y = UniqueList $ x . y
+runUniqueList :: Eq x => UniqueList x -> [x]
+runUniqueList (UniqueList x) = nub $ x []
+toUnique :: x -> UniqueList x
+toUnique = UniqueList . (:)
+
+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
+
+nonceKey :: IsString a => a
+nonceKey = "_NONCE"
+
+sessionName :: IsString a => a
+sessionName = "_SESSION"
+
+type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder
+
+data GWData a = GWData
+    !(Body a)
+    !(Last Title)
+    !(UniqueList (Script a))
+    !(UniqueList (Stylesheet a))
+    !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
+    !(Maybe (JavascriptUrl a))
+    !(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)
+        (Map.unionWith mappend a5 b5)
+        (a6 `mappend` b6)
+        (a7 `mappend` b7)

yesod-core/Yesod/Internal/Cache.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Internal.Cache
+    ( Cache
+    , CacheKey
+    , mkCacheKey
+    , lookup
+    , insert
+    , delete
+    ) where
+
+import Prelude hiding (lookup)
+import qualified Data.IntMap as Map
+import Language.Haskell.TH.Syntax (Q, Exp, runIO, Exp (LitE), Lit (IntegerL))
+import Language.Haskell.TH (appE)
+import Data.Unique (hashUnique, newUnique)
+import GHC.Exts (Any)
+import Unsafe.Coerce (unsafeCoerce)
+import Data.Monoid (Monoid)
+import Control.Applicative ((<$>))
+
+newtype Cache = Cache (Map.IntMap Any)
+    deriving Monoid
+
+newtype CacheKey a = CacheKey Int
+
+-- | Generate a new 'CacheKey'. Be sure to give a full type signature.
+mkCacheKey :: Q Exp
+mkCacheKey = [|CacheKey|] `appE` (LitE . IntegerL . fromIntegral . hashUnique <$> runIO newUnique)
+
+lookup :: CacheKey a -> Cache -> Maybe a
+lookup (CacheKey i) (Cache m) = unsafeCoerce <$> Map.lookup i m
+
+insert :: CacheKey a -> a -> Cache -> Cache
+insert (CacheKey k) v (Cache m) = Cache (Map.insert k (unsafeCoerce v) m)
+
+delete :: CacheKey a -> Cache -> Cache
+delete (CacheKey k) (Cache m) = Cache (Map.delete k m)

yesod-core/Yesod/Internal/Core.hs

@@ -0,0 +1,674 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- | The basic typeclass for a Yesod application.
+module Yesod.Internal.Core
+    ( -- * Type classes
+      Yesod (..)
+    , YesodDispatch (..)
+    , RenderRoute (..)
+      -- ** Breadcrumbs
+    , YesodBreadcrumbs (..)
+    , breadcrumbs
+      -- * Utitlities
+    , maybeAuthorized
+    , widgetToPageContent
+      -- * Defaults
+    , defaultErrorHandler
+      -- * Data types
+    , AuthResult (..)
+      -- * Logging
+    , LogLevel (..)
+    , formatLogMessage
+    , fileLocationToString
+    , messageLoggerHandler
+      -- * Misc
+    , yesodVersion
+    , yesodRender
+    , resolveApproot
+    , Approot (..)
+    ) where
+
+import Yesod.Content
+import Yesod.Handler hiding (lift, getExpires)
+
+import Yesod.Routes.Class
+
+import Control.Arrow ((***))
+import Control.Monad (forM)
+import Yesod.Widget
+import Yesod.Request
+import qualified Network.Wai as W
+import Yesod.Internal
+import Yesod.Internal.Session
+import Yesod.Internal.Request
+import Web.ClientSession (getKey, defaultKeyFile)
+import qualified Web.ClientSession as CS
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Lazy as L
+import Data.Monoid
+import Text.Hamlet
+import Text.Julius
+import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString)
+import qualified Text.Blaze.Html5 as TBH
+import Data.Text.Lazy.Builder (toLazyText)
+import Data.Text.Lazy.Encoding (encodeUtf8)
+import Data.Maybe (fromMaybe)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Web.Cookie (parseCookies)
+import qualified Data.Map as Map
+import Data.Time
+import Network.HTTP.Types (encodePath)
+import qualified Data.Text as T
+import Data.Text (Text)
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Encoding.Error as TEE
+import Blaze.ByteString.Builder (Builder, toByteString)
+import Blaze.ByteString.Builder.Char.Utf8 (fromText)
+import Data.List (foldl')
+import qualified Network.HTTP.Types as H
+import Web.Cookie (SetCookie (..))
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.IO
+import qualified Data.Text.Lazy.Builder as TB
+import Language.Haskell.TH.Syntax (Loc (..), Lift (..))
+import Text.Blaze (preEscapedLazyText)
+import Data.Aeson (Value (Array, String))
+import Data.Aeson.Encode (encode)
+import qualified Data.Vector as Vector
+import Network.Wai.Middleware.Gzip (GzipSettings, def)
+
+-- mega repo can't access this
+#ifndef MEGA
+import qualified Paths_yesod_core
+import Data.Version (showVersion)
+yesodVersion :: String
+yesodVersion = showVersion Paths_yesod_core.version
+#else
+yesodVersion :: String
+yesodVersion = "0.9.4"
+#endif
+
+#if GHC7
+#define HAMLET hamlet
+#else
+#define HAMLET $hamlet
+#endif
+
+-- | This class is automatically instantiated when you use the template haskell
+-- mkYesod function. You should never need to deal with it directly.
+class YesodDispatch sub master where
+    yesodDispatch
+        :: Yesod master
+        => master
+        -> sub
+        -> (Route sub -> Route master)
+        -> (Maybe CS.Key -> W.Application) -- ^ 404 handler
+        -> (Route sub -> Maybe CS.Key -> W.Application) -- ^ 405 handler
+        -> Text -- ^ request method
+        -> [Text] -- ^ pieces
+        -> Maybe CS.Key
+        -> W.Application
+
+    yesodRunner :: Yesod master
+                => GHandler sub master ChooseRep
+                -> master
+                -> sub
+                -> Maybe (Route sub)
+                -> (Route sub -> Route master)
+                -> Maybe CS.Key
+                -> W.Application
+    yesodRunner = defaultYesodRunner
+
+-- | 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
+
+-- | Define settings for a Yesod applications. All methods have intelligent
+-- defaults, and therefore no implementation is required.
+class RenderRoute a => Yesod a 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 a
+    approot = ApprootRelative
+
+    -- | The encryption key to be used for encrypting client sessions.
+    -- Returning 'Nothing' disables sessions.
+    encryptKey :: a -> IO (Maybe CS.Key)
+    encryptKey _ = fmap Just $ getKey defaultKeyFile
+
+    -- | Number of minutes before a client session times out. Defaults to
+    -- 120 (2 hours).
+    clientSessionDuration :: a -> Int
+    clientSessionDuration = const 120
+
+    -- | Output error response pages.
+    errorHandler :: ErrorResponse -> GHandler sub a ChooseRep
+    errorHandler = defaultErrorHandler
+
+    -- | Applies some form of layout to the contents of a page.
+    defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml
+    defaultLayout w = do
+        p <- widgetToPageContent w
+        mmsg <- getMessage
+        hamletToRepHtml [HAMLET|
+!!!
+
+<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 :: a -> Route a -> 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 a
+                 -> Bool -- ^ is this a write request?
+                 -> GHandler s a 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 a -> GHandler s a 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 :: a -> Maybe (Route a)
+    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 :: a -> [Text] -> Either [Text] [Text]
+    cleanPath _ s =
+        if corrected == s
+            then Right s
+            else Left corrected
+      where
+        corrected = filter (not . T.null) s
+
+    -- | 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 :: a
+             -> 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 pieces'
+        qs = map (TE.encodeUtf8 *** go) qs'
+        go "" = Nothing
+        go x = Just $ TE.encodeUtf8 x
+
+    -- | 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
+                     -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)])))
+    addStaticContent _ _ _ = return Nothing
+
+    {- Temporarily disabled until we have a better interface.
+    -- | Whether or not to tie a session to a specific IP address. Defaults to
+    -- 'False'.
+    --
+    -- Note: This setting has two known problems: it does not work correctly
+    -- when behind a reverse proxy (including load balancers), and it may not
+    -- function correctly if the user is behind a proxy.
+    sessionIpAddress :: a -> Bool
+    sessionIpAddress _ = False
+    -}
+
+    -- | The path value to set for cookies. By default, uses \"\/\", meaning
+    -- cookies will be sent to every page on the current domain.
+    cookiePath :: a -> S8.ByteString
+    cookiePath _ = "/"
+
+    -- | Maximum allowed length of the request body, in bytes.
+    maximumContentLength :: a -> Maybe (Route a) -> Int
+    maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
+
+    -- | Send a message to the log. By default, prints to stdout.
+    messageLogger :: a
+                  -> Loc -- ^ position in source code
+                  -> LogLevel
+                  -> Text -- ^ message
+                  -> IO ()
+    messageLogger a loc level msg =
+        if level < logLevel a
+            then return ()
+            else
+                formatLogMessage loc level msg >>=
+                Data.Text.Lazy.IO.putStrLn
+
+    -- | The logging level in place for this application. Any messages below
+    -- this level will simply be ignored.
+    logLevel :: a -> LogLevel
+    logLevel _ = LevelInfo
+
+    -- | GZIP settings.
+    gzipSettings :: a -> GzipSettings
+    gzipSettings _ = def
+
+    -- | Location of yepnope.js, if any. If one is provided, then all
+    -- Javascript files will be loaded asynchronously.
+    yepnopeJs :: a -> Maybe (Either Text (Route a))
+    yepnopeJs _ = Nothing
+
+messageLoggerHandler :: Yesod m
+                     => Loc -> LogLevel -> Text -> GHandler s m ()
+messageLoggerHandler loc level msg = do
+    y <- getYesod
+    liftIO $ messageLogger y loc level msg
+
+data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
+    deriving (Eq, Show, Read, Ord)
+
+instance Lift LogLevel where
+    lift LevelDebug = [|LevelDebug|]
+    lift LevelInfo = [|LevelInfo|]
+    lift LevelWarn = [|LevelWarn|]
+    lift LevelError = [|LevelError|]
+    lift (LevelOther x) = [|LevelOther $ T.pack $(lift $ T.unpack x)|]
+
+formatLogMessage :: Loc
+                 -> LogLevel
+                 -> Text -- ^ message
+                 -> IO TL.Text
+formatLogMessage loc level msg = do
+    now <- getCurrentTime
+    return $ TB.toLazyText $
+        TB.fromText (T.pack $ show now)
+        `mappend` TB.fromText " ["
+        `mappend` TB.fromText (T.pack $ drop 5 $ show level)
+        `mappend` TB.fromText "] "
+        `mappend` TB.fromText msg
+        `mappend` TB.fromText " @("
+        `mappend` TB.fromText (T.pack $ fileLocationToString loc)
+        `mappend` TB.fromText ") "
+
+-- 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
+
+defaultYesodRunner :: Yesod master
+                   => GHandler sub master ChooseRep
+                   -> master
+                   -> sub
+                   -> Maybe (Route sub)
+                   -> (Route sub -> Route master)
+                   -> Maybe CS.Key
+                   -> W.Application
+defaultYesodRunner _ master _ murl toMaster _ req
+    | maximumContentLength master (fmap toMaster murl) < len =
+        return $ W.responseLBS
+            (H.Status 413 "Too Large")
+            [("Content-Type", "text/plain")]
+            "Request body too large to be processed."
+  where
+    len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay
+    readMay s =
+        case reads $ S8.unpack s of
+            [] -> Nothing
+            (x, _):_ -> Just x
+defaultYesodRunner handler master sub murl toMasterRoute mkey req = do
+    now <- {-# SCC "getCurrentTime" #-} liftIO getCurrentTime
+    let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now
+    let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master
+    --let rh = {-# SCC "rh" #-} takeWhile (/= ':') $ show $ W.remoteHost req
+    let host = "" -- FIXME if sessionIpAddress master then S8.pack rh else ""
+    let session' = {-# SCC "session'" #-}
+            case mkey of
+                Nothing -> []
+                Just key -> fromMaybe [] $ do
+                    raw <- lookup "Cookie" $ W.requestHeaders req
+                    val <- lookup sessionName $ parseCookies raw
+                    decodeSession key now host val
+    rr <- liftIO $ parseWaiRequest req session' mkey
+    let h = {-# SCC "h" #-} do
+          case murl of
+            Nothing -> handler
+            Just url -> do
+                isWrite <- isWriteRequest $ toMasterRoute url
+                ar <- isAuthorized (toMasterRoute url) isWrite
+                case ar of
+                    Authorized -> return ()
+                    AuthenticationRequired ->
+                        case authRoute master of
+                            Nothing ->
+                                permissionDenied "Authentication required"
+                            Just url' -> do
+                                setUltDestCurrent
+                                redirect url'
+                    Unauthorized s' -> permissionDenied s'
+                handler
+    let sessionMap = Map.fromList
+                   $ filter (\(x, _) -> x /= nonceKey) session'
+    let ra = resolveApproot master req
+    yar <- handlerToYAR master sub toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h
+    let mnonce = reqNonce rr
+    -- FIXME should we be caching this IV value and reusing it for efficiency?
+    iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey
+    return $ yarToResponse (hr iv mnonce getExpires host exp') yar
+  where
+    hr iv mnonce getExpires host exp' hs ct sm =
+        hs'''
+      where
+        sessionVal =
+            case (mkey, mnonce) of
+                (Just key, Just nonce)
+                    -> encodeSession key iv exp' host
+                     $ Map.toList
+                     $ Map.insert nonceKey (TE.encodeUtf8 nonce) sm
+                _ -> mempty
+        hs' =
+            case mkey of
+                Nothing -> hs
+                Just _ -> AddCookie def
+                            { setCookieName = sessionName
+                            , setCookieValue = sessionVal
+                            , setCookiePath = Just (cookiePath master)
+                            , setCookieExpires = Just $ getExpires (clientSessionDuration master)
+                            , setCookieDomain = Nothing
+                            , setCookieHttpOnly = True
+                            }
+                          : hs
+        hs'' = map headerToPair hs'
+        hs''' = ("Content-Type", ct) : hs''
+
+data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
+    deriving (Eq, Show, Read)
+
+-- | A type-safe, concise method of creating breadcrumbs for pages. For each
+-- resource, you declare the title of the page and the parent resource (if
+-- present).
+class YesodBreadcrumbs y 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 y -> GHandler sub y (Text , Maybe (Route y))
+
+-- | Gets the title of the current page and the hierarchy of parent pages,
+-- along with their respective titles.
+breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, Text)])
+breadcrumbs = do
+    x' <- getCurrentRoute
+    tm <- getRouteToMaster
+    let x = fmap tm x'
+    case x of
+        Nothing -> return ("Not found", [])
+        Just y -> do
+            (title, next) <- breadcrumb y
+            z <- go [] next
+            return (title, z)
+  where
+    go back Nothing = return back
+    go back (Just this) = do
+        (title, next) <- breadcrumb this
+        go ((this, title) : back) next
+
+applyLayout' :: Yesod master
+             => Html -- ^ title
+             -> HtmlUrl (Route master) -- ^ body
+             -> GHandler sub master ChooseRep
+applyLayout' title body = fmap chooseRep $ defaultLayout $ do
+    setTitle title
+    addHamlet body
+
+-- | The default error handler for 'errorHandler'.
+defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
+defaultErrorHandler NotFound = do
+    r <- waiRequest
+    let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
+    applyLayout' "Not Found"
+        [HAMLET|
+<h1>Not Found
+<p>#{path'}
+|]
+defaultErrorHandler (PermissionDenied msg) =
+    applyLayout' "Permission Denied"
+        [HAMLET|
+<h1>Permission denied
+<p>#{msg}
+|]
+defaultErrorHandler (InvalidArgs ia) =
+    applyLayout' "Invalid Arguments"
+        [HAMLET|
+<h1>Invalid Arguments
+<ul>
+    $forall msg <- ia
+        <li>#{msg}
+|]
+defaultErrorHandler (InternalError e) =
+    applyLayout' "Internal Server Error"
+        [HAMLET|
+<h1>Internal Server Error
+<p>#{e}
+|]
+defaultErrorHandler (BadMethod m) =
+    applyLayout' "Bad Method"
+        [HAMLET|
+<h1>Method Not Supported
+<p>Method "#{S8.unpack m}" not supported
+|]
+
+-- | Return the same URL if the user is authorized to see it.
+--
+-- Built on top of 'isAuthorized'. This is useful for building page that only
+-- contain links to pages the user is allowed to see.
+maybeAuthorized :: Yesod a
+                => Route a
+                -> Bool -- ^ is this a write request?
+                -> GHandler s a (Maybe (Route a))
+maybeAuthorized r isWrite = do
+    x <- isAuthorized r isWrite
+    return $ if x == Authorized then Just r else Nothing
+
+jsToHtml :: Javascript -> Html
+jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b
+
+jelper :: JavascriptUrl url -> HtmlUrl url
+jelper = fmap jsToHtml
+
+-- | Convert a widget to a 'PageContent'.
+widgetToPageContent :: (Eq (Route master), Yesod master)
+                    => GWidget sub master ()
+                    -> GHandler sub master (PageContent (Route master))
+widgetToPageContent w = do
+    master <- getYesod
+    ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w
+    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 $ preEscapedLazyText 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, ynscripts) = ynHelper render scripts jscript jsLoc
+        headAll = [HAMLET|
+\^{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}
+$maybe eyn <- yepnopeJs master
+    $maybe yn <- left eyn
+        <script src=#{yn}>
+    $maybe yn <- right eyn
+        <script src=@{yn}>
+    $maybe complete <- mcomplete
+        <script>yepnope({load:#{ynscripts},complete:function(){^{complete}}})
+    $nothing
+        <script>yepnope({load:#{ynscripts}})
+$nothing
+    $forall s <- scripts
+        ^{mkScriptTag s}
+    $maybe j <- jscript
+        $maybe s <- jsLoc
+            <script src="#{s}">
+        $nothing
+            <script>^{jelper j}
+|]
+    return $ PageContent title headAll body
+  where
+    left (Left x) = Just x
+    left _ = Nothing
+    right (Right x) = Just x
+    right _ = Nothing
+
+    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
+            )
+
+ynHelper :: (url -> [x] -> Text)
+         -> [Script (url)]
+         -> Maybe (JavascriptUrl (url))
+         -> Maybe Text
+         -> (Maybe (HtmlUrl (url)), Html)
+ynHelper render scripts jscript jsLoc =
+    (mcomplete, unsafeLazyByteString $ encode $ Array $ Vector.fromList $ map String 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
+
+yesodRender :: Yesod y
+            => y
+            -> ResolvedApproot
+            -> Route y
+            -> [(Text, Text)] -- ^ url query string
+            -> Text
+yesodRender y ar url params =
+    TE.decodeUtf8 $ toByteString $
+    fromMaybe
+        (joinPath y ar ps
+          $ params ++ params')
+        (urlRenderOverride y url)
+  where
+    (ps, params') = renderRoute url
+
+resolveApproot :: Yesod master => master -> W.Request -> ResolvedApproot
+resolveApproot master req =
+    case approot of
+        ApprootRelative -> ""
+        ApprootStatic t -> t
+        ApprootMaster f -> f master
+        ApprootRequest f -> f master req

yesod-core/Yesod/Internal/Request.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+module Yesod.Internal.Request
+    ( parseWaiRequest
+    , Request (..)
+    , RequestBodyContents
+    , FileInfo (..)
+    -- The below are exported for testing.
+    , randomString
+    , parseWaiRequest'
+    ) where
+
+import Control.Applicative ((<$>))
+import Control.Arrow (second)
+import qualified Network.Wai.Parse as NWP
+import Yesod.Internal
+import qualified Network.Wai as W
+import System.Random (RandomGen, newStdGen, randomRs)
+import Web.Cookie (parseCookiesText)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as S8
+import Data.Text (Text, pack)
+import Network.HTTP.Types (queryToQueryText)
+import Control.Monad (join)
+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)
+import Data.Text.Encoding.Error (lenientDecode)
+
+-- | The parsed request information.
+data Request = Request
+    { reqGetParams :: [(Text, Text)]
+    , reqCookies :: [(Text, Text)]
+    , reqWaiRequest :: W.Request
+      -- | Languages which the client supports.
+    , reqLangs :: [Text]
+      -- | A random, session-specific nonce used to prevent CSRF attacks.
+    , reqNonce :: Maybe Text
+    }
+
+parseWaiRequest :: W.Request
+                -> [(Text, ByteString)] -- ^ session
+                -> Maybe a
+                -> IO Request
+parseWaiRequest env session' key' = parseWaiRequest' env session' key' <$> newStdGen
+
+parseWaiRequest' :: RandomGen g
+                 => W.Request
+                 -> [(Text, ByteString)] -- ^ session
+                 -> Maybe a
+                 -> g
+                 -> Request
+parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs'' nonce
+  where
+    gets' = queryToQueryText $ W.queryString env
+    gets'' = map (second $ fromMaybe "") gets'
+    reqCookie = lookup "Cookie" $ W.requestHeaders env
+    cookies' = maybe [] parseCookiesText reqCookie
+    acceptLang = lookup "Accept-Language" $ W.requestHeaders env
+    langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
+
+    lookupText k = fmap (decodeUtf8With lenientDecode) . lookup k
+
+    -- The language preferences are prioritized as follows:
+    langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG
+                       , lookup langKey cookies'     -- Cookie _LANG
+                       , lookupText langKey session' -- Session _LANG
+                       ] ++ langs                    -- Accept-Language(s)
+
+    -- Github issue #195. We want to add an extra two-letter version of any
+    -- language in the list.
+    langs'' = addTwoLetters (id, Set.empty) langs'
+
+    -- If sessions are disabled nonces should not be used (any
+    -- nonceKey present in the session is ignored). If sessions
+    -- are enabled and a session has no nonceKey a new one is
+    -- generated.
+    nonce = case (key', lookup nonceKey session') of
+                (Nothing, _) -> Nothing
+                (_, Just x)  -> Just $ decodeUtf8With lenientDecode x
+                _            -> Just $ pack $ randomString 10 gen
+
+addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]
+addTwoLetters (toAdd, exist) [] =
+    filter (flip Set.notMember exist) $ toAdd []
+addTwoLetters (toAdd, exist) (l:ls) =
+    l : addTwoLetters (toAdd', exist') ls
+  where
+    (toAdd', exist')
+        | T.length l > 2 = (toAdd . (T.take 2 l:), exist)
+        | otherwise = (toAdd, Set.insert l exist)
+
+-- | 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 :: RandomGen g => Int -> g -> String
+randomString len = take len . map toChar . randomRs (0, 61)
+  where
+    toChar i
+        | i < 26 = toEnum $ i + fromEnum 'A'
+        | i < 52 = toEnum $ i + fromEnum 'a' - 26
+        | otherwise = toEnum $ i + fromEnum '0' - 52
+
+-- | A tuple containing both the POST parameters and submitted files.
+type RequestBodyContents =
+    ( [(Text, Text)]
+    , [(Text, FileInfo)]
+    )
+
+data FileInfo = FileInfo
+    { fileName :: Text
+    , fileContentType :: Text
+    , fileContent :: L.ByteString
+    }
+    deriving (Eq, Show)

yesod-core/Yesod/Internal/Session.hs

@@ -0,0 +1,57 @@
+module Yesod.Internal.Session
+    ( encodeSession
+    , decodeSession
+    ) where
+
+import qualified Web.ClientSession as CS
+import Data.Serialize
+import Data.Time
+import Data.ByteString (ByteString)
+import Control.Monad (guard)
+import Data.Text (Text, pack, unpack)
+import Control.Arrow (first)
+import Control.Applicative ((<$>))
+
+encodeSession :: CS.Key
+              -> CS.IV
+              -> UTCTime -- ^ expire time
+              -> ByteString -- ^ remote host
+              -> [(Text, ByteString)] -- ^ session
+              -> ByteString -- ^ cookie value
+encodeSession key iv expire rhost session' =
+    CS.encrypt key iv $ encode $ SessionCookie expire rhost session'
+
+decodeSession :: CS.Key
+              -> UTCTime -- ^ current time
+              -> ByteString -- ^ remote host field
+              -> ByteString -- ^ cookie value
+              -> Maybe [(Text, ByteString)]
+decodeSession key now rhost encrypted = do
+    decrypted <- CS.decrypt key encrypted
+    SessionCookie expire rhost' session' <-
+        either (const Nothing) Just $ decode decrypted
+    guard $ expire > now
+    guard $ rhost' == rhost
+    return session'
+
+data SessionCookie = SessionCookie UTCTime ByteString [(Text, ByteString)]
+    deriving (Show, Read)
+instance Serialize SessionCookie where
+    put (SessionCookie a b c) = putTime a >> put b >> put (map (first unpack) c)
+    get = do
+        a <- getTime
+        b <- get
+        c <- map (first pack) <$> get
+        return $ SessionCookie a b c
+
+putTime :: Putter UTCTime
+putTime t@(UTCTime d _) = do
+    put $ toModifiedJulianDay d
+    let ndt = diffUTCTime t $ UTCTime d 0
+    put $ toRational ndt
+
+getTime :: Get UTCTime
+getTime = do
+    d <- get
+    ndt <- get
+    return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0

yesod-core/Yesod/Internal/TestApi.hs

@@ -0,0 +1,11 @@
+--
+-- | WARNING: This module exposes internal interfaces solely for the
+-- purpose of facilitating cabal-driven testing of said interfaces.
+-- This module is NOT part of the public Yesod API and should NOT be
+-- imported by library users.
+--
+module Yesod.Internal.TestApi
+  ( randomString, parseWaiRequest'
+  ) where
+
+import Yesod.Internal.Request (randomString, parseWaiRequest')

yesod-core/Yesod/Logger.hs

@@ -0,0 +1,138 @@
+{-# LANGUAGE BangPatterns #-}
+module Yesod.Logger
+    ( Logger
+    , handle
+    , developmentLogger, productionLogger
+    , defaultDevelopmentLogger, defaultProductionLogger
+    , toProduction
+    , flushLogger
+    , logText
+    , logLazyText
+    , logString
+    , logBS
+    , logMsg
+    , formatLogText
+    , timed
+    -- * Deprecated
+    , makeLoggerWithHandle
+    , makeDefaultLogger
+    ) where
+
+import System.IO (Handle, stdout, hFlush)
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 (pack)
+import Data.ByteString.Lazy (toChunks)
+import qualified Data.Text.Lazy as TL
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text.Lazy.Encoding as TLE
+import System.Log.FastLogger
+import Network.Wai.Logger.Date (DateRef, dateInit, getDate)
+
+-- for timed logging
+import Data.Time (getCurrentTime, diffUTCTime)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Text.Printf (printf)
+import Data.Text (unpack)
+
+-- for formatter
+import Language.Haskell.TH.Syntax (Loc)
+import Yesod.Core (LogLevel, fileLocationToString)
+
+data Logger = Logger {
+    loggerLogFun   :: [LogStr] -> IO ()
+  , loggerHandle   :: Handle
+  , loggerDateRef  :: DateRef
+  }
+
+handle :: Logger -> Handle
+handle = loggerHandle
+
+flushLogger :: Logger -> IO ()
+flushLogger = hFlush . loggerHandle
+
+makeDefaultLogger :: IO Logger
+makeDefaultLogger = defaultDevelopmentLogger
+{-# DEPRECATED makeDefaultLogger "Use defaultProductionLogger or defaultDevelopmentLogger instead" #-}
+
+makeLoggerWithHandle, developmentLogger, productionLogger :: Handle -> IO Logger
+makeLoggerWithHandle = productionLogger
+{-# DEPRECATED makeLoggerWithHandle "Use productionLogger or developmentLogger instead" #-}
+
+-- | uses stdout handle
+defaultProductionLogger, defaultDevelopmentLogger :: IO Logger
+defaultProductionLogger = productionLogger stdout
+defaultDevelopmentLogger = developmentLogger stdout
+
+
+productionLogger h = mkLogger h (handleToLogFun h)
+-- | a development logger gets automatically flushed
+developmentLogger h = mkLogger h (\bs -> (handleToLogFun h) bs >> hFlush h)
+
+mkLogger :: Handle -> ([LogStr] -> IO ()) -> IO Logger
+mkLogger h logFun = do
+    initHandle h
+    dateInit >>= return . Logger logFun h
+
+-- convert (a development) logger to production settings
+toProduction :: Logger -> Logger
+toProduction (Logger _ h d) = Logger (handleToLogFun h) h d
+
+handleToLogFun :: Handle -> ([LogStr] -> IO ())
+handleToLogFun = hPutLogStr
+
+logMsg :: Logger -> [LogStr] -> IO ()
+logMsg = hPutLogStr . handle
+
+logLazyText :: Logger -> TL.Text -> IO ()
+logLazyText logger msg = loggerLogFun logger $
+  map LB (toChunks $ TLE.encodeUtf8 msg) ++ [newLine]
+
+logText :: Logger -> Text -> IO ()
+logText logger = logBS logger . encodeUtf8
+
+logBS :: Logger -> ByteString -> IO ()
+logBS logger msg = loggerLogFun logger $ [LB msg, newLine]
+
+logString :: Logger -> String -> IO ()
+logString logger msg = loggerLogFun logger $ [LS msg, newLine]
+
+formatLogText :: Logger -> Loc -> LogLevel -> Text -> IO [LogStr]
+formatLogText logger loc level msg = formatLogMsg logger loc level (toLB msg)
+
+toLB :: Text -> LogStr
+toLB = LB . encodeUtf8
+
+formatLogMsg :: Logger -> Loc -> LogLevel -> LogStr -> IO [LogStr]
+formatLogMsg logger loc level msg = do
+    date <- liftIO $ getDate $ loggerDateRef logger
+    return
+        [ LB date
+        , LB $ pack" ["
+        , LS (drop 5 $ show level)
+        , LB $ pack "] "
+        , msg
+        , LB $ pack " @("
+        , LS (fileLocationToString loc)
+        , LB $ pack ") "
+        ]
+
+newLine :: LogStr
+newLine = LB $ pack "\n"
+
+-- | Execute a monadic action and log the duration
+--
+timed :: MonadIO m
+      => Logger  -- ^ Logger
+      -> Text  -- ^ Message
+      -> m a     -- ^ Action
+      -> m a     -- ^ Timed and logged action
+timed logger msg action = do
+    start <- liftIO getCurrentTime
+    !result <- action
+    stop <- liftIO getCurrentTime
+    let diff = fromEnum $ diffUTCTime stop start
+        ms = diff `div` 10 ^ (9 :: Int)
+        formatted = printf "  [%4dms] %s" ms (unpack msg)
+    liftIO $ logString logger formatted
+    return result

yesod-core/Yesod/Message.hs

@@ -0,0 +1,6 @@
+-- | This module has moved to "Text.Shakespeare.I18N"
+module Yesod.Message
+    ( module Text.Shakespeare.I18N
+    ) where
+
+import Text.Shakespeare.I18N

yesod-core/Yesod/Request.hs

@@ -0,0 +1,101 @@
+---------------------------------------------------------
+--
+-- Module        : Yesod.Request
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- Stability     : Stable
+-- Portability   : portable
+--
+-- | Provides a parsed version of the raw 'W.Request' data.
+--
+---------------------------------------------------------
+module Yesod.Request
+    (
+      -- * Request datatype
+      RequestBodyContents
+    , Request (..)
+    , FileInfo (..)
+      -- * Convenience functions
+    , languages
+      -- * Lookup parameters
+    , lookupGetParam
+    , lookupPostParam
+    , lookupCookie
+    , lookupFile
+      -- ** Multi-lookup
+    , lookupGetParams
+    , lookupPostParams
+    , lookupCookies
+    , lookupFiles
+    ) where
+
+import Yesod.Internal.Request
+import Yesod.Handler
+import Control.Monad (liftM)
+import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+
+-- | Get the list of supported languages supplied by the user.
+--
+-- Languages are determined based on the following three (in descending order
+-- of preference):
+--
+-- * The _LANG get parameter.
+--
+-- * The _LANG cookie.
+--
+-- * The _LANG user session variable.
+--
+-- * Accept-Language HTTP header.
+--
+-- This is handled by parseWaiRequest (not exposed).
+languages :: GHandler s m [Text]
+languages = reqLangs `liftM` getRequest
+
+lookup' :: Eq a => a -> [(a, b)] -> [b]
+lookup' a = map snd . filter (\x -> a == fst x)
+
+-- | Lookup for GET parameters.
+lookupGetParams :: Text -> GHandler s m [Text]
+lookupGetParams pn = do
+    rr <- getRequest
+    return $ lookup' pn $ reqGetParams rr
+
+-- | Lookup for GET parameters.
+lookupGetParam :: Text -> GHandler s m (Maybe Text)
+lookupGetParam = liftM listToMaybe . lookupGetParams
+
+-- | Lookup for POST parameters.
+lookupPostParams :: Text -> GHandler s m [Text]
+lookupPostParams pn = do
+    (pp, _) <- runRequestBody
+    return $ lookup' pn pp
+
+lookupPostParam :: Text
+                -> GHandler s m (Maybe Text)
+lookupPostParam = liftM listToMaybe . lookupPostParams
+
+-- | Lookup for POSTed files.
+lookupFile :: Text
+           -> GHandler s m (Maybe FileInfo)
+lookupFile = liftM listToMaybe . lookupFiles
+
+-- | Lookup for POSTed files.
+lookupFiles :: Text
+            -> GHandler s m [FileInfo]
+lookupFiles pn = do
+    (_, files) <- runRequestBody
+    return $ lookup' pn files
+
+-- | Lookup for cookie data.
+lookupCookie :: Text -> GHandler s m (Maybe Text)
+lookupCookie = liftM listToMaybe . lookupCookies
+
+-- | Lookup for cookie data.
+lookupCookies :: Text -> GHandler s m [Text]
+lookupCookies pn = do
+    rr <- getRequest
+    return $ lookup' pn $ reqCookies rr