Compare commits
No commits in common. "master" and "149-drop-lazy-io" have entirely different histories.
master
...
149-drop-l
29
.github/ISSUE_TEMPLATE.md
vendored
29
.github/ISSUE_TEMPLATE.md
vendored
@ -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.
|
||||
-->
|
||||
14
.github/PULL_REQUEST_TEMPLATE.md
vendored
14
.github/PULL_REQUEST_TEMPLATE.md
vendored
@ -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_-->
|
||||
56
.github/workflows/tests.yml
vendored
56
.github/workflows/tests.yml
vendored
@ -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 }}
|
||||
6
.gitignore
vendored
6
.gitignore
vendored
@ -4,7 +4,6 @@
|
||||
*.hi
|
||||
dist/
|
||||
dist-stack/
|
||||
stack.yaml.lock
|
||||
.stack-work
|
||||
*.swp
|
||||
client_session_key.aes
|
||||
@ -22,8 +21,3 @@ tarballs/
|
||||
.ghc
|
||||
.stackage
|
||||
.bash_history
|
||||
|
||||
# OS X
|
||||
.DS_Store
|
||||
*.yaml.lock
|
||||
dist-newstyle/
|
||||
|
||||
192
.travis.yml
Normal file
192
.travis.yml
Normal file
@ -0,0 +1,192 @@
|
||||
# Copy these contents into the root directory of your Github project in a file
|
||||
# named .travis.yml
|
||||
|
||||
# Use new container infrastructure to enable caching
|
||||
sudo: false
|
||||
|
||||
# Choose a lightweight base image; we provide our own build tools.
|
||||
language: c
|
||||
|
||||
# Caching so the next build will be fast too.
|
||||
cache:
|
||||
directories:
|
||||
- $HOME/.ghc
|
||||
- $HOME/.cabal
|
||||
- $HOME/.stack
|
||||
|
||||
# The different configurations we want to test. We have BUILD=cabal which uses
|
||||
# cabal-install, and BUILD=stack which uses Stack. More documentation on each
|
||||
# of those below.
|
||||
#
|
||||
# We set the compiler values here to tell Travis to use a different
|
||||
# cache file per set of arguments.
|
||||
#
|
||||
# If you need to have different apt packages for each combination in the
|
||||
# matrix, you can use a line such as:
|
||||
# addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}
|
||||
matrix:
|
||||
include:
|
||||
# We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:
|
||||
# https://github.com/hvr/multi-ghc-travis
|
||||
#- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
# compiler: ": #GHC 7.0.4"
|
||||
# addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
|
||||
#- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
# compiler: ": #GHC 7.2.2"
|
||||
# addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
|
||||
#- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
# compiler: ": #GHC 7.4.2"
|
||||
# addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
|
||||
#- env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
# compiler: ": #GHC 7.6.3"
|
||||
# addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
|
||||
- env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
compiler: ": #GHC 7.8.4"
|
||||
addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
|
||||
- env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
compiler: ": #GHC 7.10.3"
|
||||
addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
|
||||
- env: BUILD=cabal GHCVER=8.0.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
compiler: ": #GHC 8.0.1"
|
||||
addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
|
||||
|
||||
# Build with the newest GHC and cabal-install. This is an accepted failure,
|
||||
# see below.
|
||||
- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
compiler: ": #GHC HEAD"
|
||||
addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
|
||||
|
||||
# The Stack builds. We can pass in arbitrary Stack arguments via the ARGS
|
||||
# variable, such as using --stack-yaml to point to a different file.
|
||||
- env: BUILD=stack ARGS=""
|
||||
compiler: ": #stack default"
|
||||
addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}}
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver lts-2"
|
||||
compiler: ": #stack 7.8.4"
|
||||
addons: {apt: {packages: [ghc-7.8.4], sources: [hvr-ghc]}}
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver lts-3"
|
||||
compiler: ": #stack 7.10.2"
|
||||
addons: {apt: {packages: [ghc-7.10.2], sources: [hvr-ghc]}}
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver lts-6"
|
||||
compiler: ": #stack 7.10.3"
|
||||
addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}}
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver lts-7"
|
||||
compiler: ": #stack 8.0.1"
|
||||
addons: {apt: {packages: [ghc-8.0.1], sources: [hvr-ghc]}}
|
||||
|
||||
# Nightly builds are allowed to fail
|
||||
- env: BUILD=stack ARGS="--resolver nightly"
|
||||
compiler: ": #stack nightly"
|
||||
addons: {apt: {packages: [libgmp,libgmp-dev]}}
|
||||
|
||||
# Build on OS X in addition to Linux
|
||||
- env: BUILD=stack ARGS=""
|
||||
compiler: ": #stack default osx"
|
||||
os: osx
|
||||
|
||||
# Doesn't include hfsevents
|
||||
#- env: BUILD=stack ARGS="--resolver lts-2"
|
||||
# compiler: ": #stack 7.8.4 osx"
|
||||
# os: osx
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver lts-3"
|
||||
compiler: ": #stack 7.10.2 osx"
|
||||
os: osx
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver lts-6"
|
||||
compiler: ": #stack 7.10.3 osx"
|
||||
os: osx
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver lts-7"
|
||||
compiler: ": #stack 8.0.1 osx"
|
||||
os: osx
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver nightly"
|
||||
compiler: ": #stack nightly osx"
|
||||
os: osx
|
||||
|
||||
allow_failures:
|
||||
- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
- env: BUILD=stack ARGS="--resolver nightly"
|
||||
|
||||
before_install:
|
||||
# Using compiler above sets CC to an invalid value, so unset it
|
||||
- unset CC
|
||||
|
||||
# We want to always allow newer versions of packages when building on GHC HEAD
|
||||
- CABALARGS=""
|
||||
- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi
|
||||
|
||||
# Download and unpack the stack executable
|
||||
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH
|
||||
- mkdir -p ~/.local/bin
|
||||
- |
|
||||
if [ `uname` = "Darwin" ]
|
||||
then
|
||||
travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin
|
||||
else
|
||||
travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
|
||||
fi
|
||||
|
||||
# Use the more reliable S3 mirror of Hackage
|
||||
mkdir -p $HOME/.cabal
|
||||
echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config
|
||||
echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config
|
||||
|
||||
if [ "$CABALVER" != "1.16" ]
|
||||
then
|
||||
echo 'jobs: $ncpus' >> $HOME/.cabal/config
|
||||
fi
|
||||
|
||||
# Get the list of packages from the stack.yaml file
|
||||
- PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')
|
||||
|
||||
install:
|
||||
- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
|
||||
- if [ -f configure.ac ]; then autoreconf -i; fi
|
||||
- |
|
||||
set -ex
|
||||
case "$BUILD" in
|
||||
stack)
|
||||
stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies
|
||||
;;
|
||||
cabal)
|
||||
cabal --version
|
||||
travis_retry cabal update
|
||||
cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
|
||||
;;
|
||||
esac
|
||||
set +ex
|
||||
|
||||
script:
|
||||
- |
|
||||
set -ex
|
||||
case "$BUILD" in
|
||||
stack)
|
||||
stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
|
||||
;;
|
||||
cabal)
|
||||
cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
|
||||
|
||||
ORIGDIR=$(pwd)
|
||||
for dir in $PACKAGES
|
||||
do
|
||||
cd $dir
|
||||
cabal check || [ "$CABALVER" == "1.16" ]
|
||||
cabal sdist
|
||||
PKGVER=$(cabal info . | awk '{print $2;exit}')
|
||||
SRC_TGZ=$PKGVER.tar.gz
|
||||
cd dist
|
||||
tar zxfv "$SRC_TGZ"
|
||||
cd "$PKGVER"
|
||||
cabal configure --enable-tests
|
||||
cabal build
|
||||
cd $ORIGDIR
|
||||
done
|
||||
;;
|
||||
esac
|
||||
set +ex
|
||||
@ -1,74 +1,13 @@
|
||||
# Contributor Covenant Code of Conduct
|
||||
# Contributor Code of Conduct
|
||||
|
||||
## Our Pledge
|
||||
Always be nice.
|
||||
|
||||
In the interest of fostering an open and welcoming environment, we as
|
||||
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.
|
||||
When communicating online treat people the way you would if
|
||||
they were standing next to you.
|
||||
|
||||
## Our Standards
|
||||
Don't forget to be nice whenever representing the
|
||||
project to others outside the project.
|
||||
|
||||
Examples of behavior that contributes to creating a positive environment
|
||||
include:
|
||||
|
||||
* Using welcoming and inclusive language
|
||||
* Being respectful of differing viewpoints and experiences
|
||||
* Gracefully accepting constructive criticism
|
||||
* Focusing on what is best for the community
|
||||
* Showing empathy towards other community members
|
||||
|
||||
Examples of unacceptable behavior by participants include:
|
||||
|
||||
* The use of sexualized language or imagery and unwelcome sexual attention or
|
||||
advances
|
||||
* Trolling, insulting/derogatory comments, and personal or political attacks
|
||||
* Public or private harassment
|
||||
* Publishing others' private information, such as a physical or electronic
|
||||
address, without explicit permission
|
||||
* Other conduct which could reasonably be considered inappropriate in a
|
||||
professional setting
|
||||
|
||||
## Our Responsibilities
|
||||
|
||||
Project maintainers are responsible for clarifying the standards of acceptable
|
||||
behavior and are expected to take appropriate and fair corrective action in
|
||||
response to any instances of unacceptable behavior.
|
||||
|
||||
Project maintainers have the right and responsibility to remove, edit, or
|
||||
reject comments, commits, code, wiki edits, issues, and other contributions
|
||||
that are not aligned to this Code of Conduct, or to ban temporarily or
|
||||
permanently any contributor for other behaviors that they deem inappropriate,
|
||||
threatening, offensive, or harmful.
|
||||
|
||||
## Scope
|
||||
|
||||
This Code of Conduct applies both within project spaces and in public spaces
|
||||
when an individual is representing the project or its community. Examples of
|
||||
representing a project or community include using an official project e-mail
|
||||
address, posting via an official social media account, or acting as an appointed
|
||||
representative at an online or offline event. Representation of a project may be
|
||||
further defined and clarified by project maintainers.
|
||||
|
||||
## Enforcement
|
||||
|
||||
Instances of abusive, harassing, or otherwise unacceptable behavior may be
|
||||
reported by contacting the project team at `michael at snoyman dot com`. All
|
||||
complaints will be reviewed and investigated and will result in a response that
|
||||
is deemed necessary and appropriate to the circumstances. The project team is
|
||||
obligated to maintain confidentiality with regard to the reporter of an incident.
|
||||
Further details of specific enforcement policies may be posted separately.
|
||||
|
||||
Project maintainers who do not follow or enforce the Code of Conduct in good
|
||||
faith may face temporary or permanent repercussions as determined by other
|
||||
members of the project's leadership.
|
||||
|
||||
## Attribution
|
||||
|
||||
This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4,
|
||||
available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html
|
||||
|
||||
[homepage]: https://www.contributor-covenant.org
|
||||
If you are not nice, apologize.
|
||||
|
||||
If someone is not being nice, tell them in a respectful way or tell a project maintainer: we care about fostering a welcoming community.
|
||||
|
||||
@ -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.
|
||||
2
LICENSE
2
LICENSE
@ -1,4 +1,4 @@
|
||||
Copyright (c) 2012-2017 Michael Snoyman, http://www.yesodweb.com/
|
||||
Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining
|
||||
a copy of this software and associated documentation files (the
|
||||
|
||||
15
README
Normal file
15
README
Normal file
@ -0,0 +1,15 @@
|
||||
Authentication methods for Haskell web applications.
|
||||
|
||||
Note for Rpxnow:
|
||||
By default on some (all?) installs wget does not come with root certificates
|
||||
for SSL. If this is the case then Web.Authenticate.Rpxnow.authenticate will
|
||||
fail as wget cannot establish a secure connection to rpxnow's servers.
|
||||
|
||||
A simple *nix solution, if potentially insecure (man in the middle attacks as
|
||||
you are downloading the certs) is to grab a copy of the certs extracted from
|
||||
those that come with firefox, hosted by CURL at
|
||||
http://curl.haxx.se/ca/cacert.pem , put them somewhere (for ex,
|
||||
~/.wget/cacert.pem) and then edit your ~/.wgetrc to include:
|
||||
ca_certificate=~/.wget/cacert.pem
|
||||
|
||||
This should fix the problem.
|
||||
40
README.md
40
README.md
@ -1,4 +1,4 @@
|
||||
|
||||
[](https://travis-ci.org/yesodweb/yesod)
|
||||
|
||||
# Yesod Web Framework
|
||||
|
||||
@ -12,50 +12,20 @@ An advanced web framework using the Haskell programming language. Featuring:
|
||||
* asynchronous IO
|
||||
* this is built in to the Haskell programming language (like Erlang)
|
||||
|
||||
## Getting Started
|
||||
|
||||
Learn more about Yesod on [its main website](http://www.yesodweb.com/). If you
|
||||
want to get started using Yesod, we strongly recommend the [quick start
|
||||
guide](http://www.yesodweb.com/page/quickstart), based on [the Haskell build
|
||||
tool stack](https://github.com/commercialhaskell/stack#readme).
|
||||
|
||||
Here's a minimal example!
|
||||
|
||||
```haskell
|
||||
{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies #-}
|
||||
|
||||
import Yesod
|
||||
|
||||
data App = App -- Put your config, database connection pool, etc. in here.
|
||||
|
||||
-- Derive routes and instances for App.
|
||||
mkYesod "App" [parseRoutes|
|
||||
/ HomeR GET
|
||||
|]
|
||||
|
||||
instance Yesod App -- Methods in here can be overridden as needed.
|
||||
|
||||
-- The handler for the GET request at /, corresponds to HomeR.
|
||||
getHomeR :: Handler Html
|
||||
getHomeR = defaultLayout [whamlet|Hello World!|]
|
||||
|
||||
main :: IO ()
|
||||
main = warp 3000 App
|
||||
```
|
||||
|
||||
To read about each of the concepts in use above (routing, handlers,
|
||||
linking, JSON), in detail, visit
|
||||
[Basics in the Yesod book](https://www.yesodweb.com/book/basics#basics_routing).
|
||||
|
||||
## Hacking on Yesod
|
||||
|
||||
Yesod consists mostly of four repositories:
|
||||
|
||||
```bash
|
||||
git clone --recurse-submodules http://github.com/yesodweb/shakespeare
|
||||
git clone --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
|
||||
git clone --recursive http://github.com/yesodweb/shakespeare
|
||||
git clone --recursive http://github.com/yesodweb/persistent
|
||||
git clone --recursive http://github.com/yesodweb/wai
|
||||
git clone --recursive http://github.com/yesodweb/yesod
|
||||
```
|
||||
|
||||
Each repository can be built with `stack build`.
|
||||
|
||||
5
ReleaseNotes.md
Normal file
5
ReleaseNotes.md
Normal file
@ -0,0 +1,5 @@
|
||||
Release notes are maintained on the wiki.
|
||||
|
||||
https://github.com/yesodweb/yesod/wiki/Changelog (high level features)
|
||||
|
||||
https://github.com/yesodweb/yesod/wiki/Detailed-change-list (see for breaking changes)
|
||||
@ -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
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
@ -14,6 +15,7 @@ import Data.Yaml
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Text.Lazy.Encoding as LTE
|
||||
import Data.Typeable (Typeable)
|
||||
import Database.Persist.Sqlite
|
||||
import Database.Persist.TH
|
||||
import Network.Mail.Mime
|
||||
@ -35,6 +37,7 @@ User
|
||||
verkey Text Maybe -- Used for resetting passwords
|
||||
verified Bool
|
||||
UniqueUser email
|
||||
deriving Typeable
|
||||
|]
|
||||
|
||||
data App = App
|
||||
|
||||
@ -21,7 +21,7 @@ data Wiki = Wiki
|
||||
}
|
||||
|
||||
-- | A typeclass that all master sites that want a Wiki must implement. A
|
||||
-- master must be able to render form messages, as we use yesod-form for
|
||||
-- master must be able to render form messages, as we use yesod-forms for
|
||||
-- processing user input.
|
||||
class (RenderMessage master FormMessage, Yesod master) => YesodWiki master where
|
||||
-- | Write protection. By default, no protection.
|
||||
|
||||
13
sources.txt
Normal file
13
sources.txt
Normal file
@ -0,0 +1,13 @@
|
||||
./yesod-core
|
||||
./yesod-static
|
||||
./yesod-persistent
|
||||
./yesod-newsfeed
|
||||
./yesod-form
|
||||
./yesod-auth
|
||||
./yesod-auth-oauth
|
||||
./yesod-sitemap
|
||||
./yesod-test
|
||||
./yesod-bin
|
||||
./yesod
|
||||
./yesod-eventsource
|
||||
./yesod-websockets
|
||||
38
stack.yaml
38
stack.yaml
@ -1,19 +1,25 @@
|
||||
resolver: lts-18.3
|
||||
resolver: lts-5.6
|
||||
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
|
||||
- ./yesod-core
|
||||
- ./yesod-static
|
||||
- ./yesod-persistent
|
||||
- ./yesod-newsfeed
|
||||
- ./yesod-form
|
||||
- ./yesod-auth
|
||||
- ./yesod-auth-oauth
|
||||
- ./yesod-sitemap
|
||||
- ./yesod-test
|
||||
- ./yesod-bin
|
||||
- ./yesod
|
||||
- ./yesod-eventsource
|
||||
- ./yesod-websockets
|
||||
|
||||
# Needed for LTS 2
|
||||
extra-deps:
|
||||
- attoparsec-aeson-2.1.0.0
|
||||
- wai-app-static-3.1.4.1
|
||||
- http-api-data-0.2
|
||||
- yaml-0.8.17
|
||||
- nonce-1.0.2
|
||||
- persistent-2.5
|
||||
- persistent-sqlite-2.5
|
||||
- cookie-0.4.2
|
||||
|
||||
@ -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
|
||||
@ -1,29 +1,3 @@
|
||||
# ChangeLog for yesod-auth-oauth
|
||||
|
||||
## 1.6.1
|
||||
|
||||
* Allow newer GHC
|
||||
|
||||
## 1.6.0.3
|
||||
|
||||
* Allow yesod-form 1.7
|
||||
|
||||
## 1.6.0.2
|
||||
|
||||
* Remove unnecessary deriving of Typeable
|
||||
|
||||
## 1.6.0.1
|
||||
|
||||
* Compile with GHC 8.6 [#1561](https://github.com/yesodweb/yesod/pull/1561)
|
||||
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
|
||||
## 1.4.2
|
||||
|
||||
* Fix warnings
|
||||
|
||||
## 1.4.1
|
||||
|
||||
* change OAuth Twitter ID, screen_name → user_id [#1168](https://github.com/yesodweb/yesod/pull/1168)
|
||||
|
||||
@ -1,9 +1,5 @@
|
||||
{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
|
||||
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Yesod.Auth.OAuth
|
||||
( authOAuth
|
||||
, oauthUrl
|
||||
@ -14,9 +10,9 @@ module Yesod.Auth.OAuth
|
||||
, tumblrUrl
|
||||
, module Web.Authenticate.OAuth
|
||||
) where
|
||||
import Control.Applicative as A ((<$>), (<*>))
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Control.Arrow ((***))
|
||||
import UnliftIO.Exception
|
||||
import Control.Exception.Lifted
|
||||
import Control.Monad.IO.Class
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe
|
||||
@ -24,6 +20,7 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Data.Typeable
|
||||
import Web.Authenticate.OAuth
|
||||
import Yesod.Auth
|
||||
import Yesod.Form
|
||||
@ -31,42 +28,34 @@ import Yesod.Core
|
||||
|
||||
data YesodOAuthException = CredentialError String Credential
|
||||
| SessionError String
|
||||
deriving Show
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance Exception YesodOAuthException
|
||||
|
||||
oauthUrl :: Text -> AuthRoute
|
||||
oauthUrl name = PluginR name ["forward"]
|
||||
|
||||
authOAuth :: forall master. YesodAuth master
|
||||
authOAuth :: YesodAuth m
|
||||
=> OAuth -- ^ 'OAuth' data-type for signing.
|
||||
-> (Credential -> IO (Creds master)) -- ^ How to extract ident.
|
||||
-> AuthPlugin master
|
||||
-> (Credential -> IO (Creds m)) -- ^ How to extract ident.
|
||||
-> AuthPlugin m
|
||||
authOAuth oauth mkCreds = AuthPlugin name dispatch login
|
||||
where
|
||||
name = T.pack $ oauthServerName oauth
|
||||
url = PluginR name []
|
||||
lookupTokenSecret = bsToText . fromMaybe "" . lookup "oauth_token_secret" . unCredential
|
||||
|
||||
oauthSessionName :: Text
|
||||
oauthSessionName = "__oauth_token_secret"
|
||||
|
||||
dispatch
|
||||
:: Text
|
||||
-> [Text]
|
||||
-> AuthHandler master TypedContent
|
||||
dispatch "GET" ["forward"] = do
|
||||
render <- getUrlRender
|
||||
render <- lift getUrlRender
|
||||
tm <- getRouteToParent
|
||||
let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
|
||||
manager <- authHttpManager
|
||||
tok <- getTemporaryCredential oauth' manager
|
||||
master <- lift getYesod
|
||||
tok <- lift $ getTemporaryCredential oauth' (authHttpManager master)
|
||||
setSession oauthSessionName $ lookupTokenSecret tok
|
||||
redirect $ authorizeUrl oauth' tok
|
||||
dispatch "GET" [] = do
|
||||
tokSec <- lookupSession oauthSessionName >>= \case
|
||||
Just t -> return t
|
||||
Nothing -> liftIO $ fail "lookupSession could not find session"
|
||||
dispatch "GET" [] = lift $ do
|
||||
Just tokSec <- lookupSession oauthSessionName
|
||||
deleteSession oauthSessionName
|
||||
reqTok <-
|
||||
if oauthVersion oauth == OAuth10
|
||||
@ -77,14 +66,14 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
|
||||
]
|
||||
else do
|
||||
(verifier, oaTok) <-
|
||||
runInputGet $ (,) A.<$> ireq textField "oauth_verifier"
|
||||
A.<*> ireq textField "oauth_token"
|
||||
runInputGet $ (,) <$> ireq textField "oauth_verifier"
|
||||
<*> 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
|
||||
master <- getYesod
|
||||
accTok <- getAccessToken oauth reqTok (authHttpManager master)
|
||||
creds <- liftIO $ mkCreds accTok
|
||||
setCredsRedirect creds
|
||||
dispatch _ _ = notFound
|
||||
@ -94,7 +83,7 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
|
||||
let oaUrl = render $ tm $ oauthUrl name
|
||||
[whamlet| <a href=#{oaUrl}>Login via #{name} |]
|
||||
|
||||
mkExtractCreds :: Text -> String -> Credential -> IO (Creds m)
|
||||
mkExtractCreds :: YesodAuth m => Text -> String -> Credential -> IO (Creds m)
|
||||
mkExtractCreds name idName (Credential dic) = do
|
||||
let mcrId = decodeUtf8With lenientDecode <$> lookup (encodeUtf8 $ T.pack idName) dic
|
||||
case mcrId of
|
||||
@ -124,7 +113,7 @@ authTwitter :: YesodAuth m
|
||||
-> ByteString -- ^ Consumer Secret
|
||||
-> AuthPlugin m
|
||||
authTwitter key secret = authTwitter' key secret "screen_name"
|
||||
{-# DEPRECATED authTwitter "Use authTwitterUsingUserId instead" #-}
|
||||
{-# DEPRECATED authTwitter "Use authTwitterUsingUserID instead" #-}
|
||||
|
||||
-- | Twitter plugin which uses Twitter's /user_id/ as ID.
|
||||
--
|
||||
|
||||
@ -1,6 +1,5 @@
|
||||
cabal-version: >= 1.10
|
||||
name: yesod-auth-oauth
|
||||
version: 1.6.1
|
||||
version: 1.4.1.1
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Hiromi Ishii
|
||||
@ -8,21 +7,28 @@ maintainer: Michael Litchard
|
||||
synopsis: OAuth Authentication for Yesod.
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.6.0
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-auth-oauth>
|
||||
extra-source-files: README.md ChangeLog.md
|
||||
|
||||
flag ghc7
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
build-depends: authenticate-oauth >= 1.5 && < 1.8
|
||||
, base >= 4.10 && < 5
|
||||
if flag(ghc7)
|
||||
build-depends: base >= 4.3 && < 5
|
||||
cpp-options: -DGHC7
|
||||
else
|
||||
build-depends: base >= 4 && < 4.3
|
||||
build-depends: authenticate-oauth >= 1.5 && < 1.6
|
||||
, bytestring >= 0.9.1.4
|
||||
, yesod-core >= 1.4 && < 1.5
|
||||
, yesod-auth >= 1.4 && < 1.5
|
||||
, text >= 0.7
|
||||
, unliftio
|
||||
, yesod-auth >= 1.6 && < 1.7
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, yesod-form >= 1.6 && < 1.8
|
||||
, yesod-form >= 1.4 && < 1.5
|
||||
, transformers >= 0.2.2 && < 0.6
|
||||
, lifted-base >= 0.2 && < 0.3
|
||||
exposed-modules: Yesod.Auth.OAuth
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
@ -1,159 +1,3 @@
|
||||
# ChangeLog for yesod-auth
|
||||
|
||||
## 1.6.11.2
|
||||
|
||||
* Add support for aeson 2.2 [#1820](https://github.com/yesodweb/yesod/pull/1820)
|
||||
|
||||
## 1.6.11.1
|
||||
|
||||
* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
|
||||
|
||||
## 1.6.11
|
||||
|
||||
* Add support for aeson 2
|
||||
|
||||
## 1.6.10.5
|
||||
|
||||
* Fix German translations of AuthMessage [#1741](https://github.com/yesodweb/yesod/pull/1741)
|
||||
|
||||
## 1.6.10.4
|
||||
|
||||
* Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737)
|
||||
|
||||
## 1.6.10.3
|
||||
|
||||
* Relax bounds for yesod-form 1.7
|
||||
|
||||
## 1.6.10.2
|
||||
|
||||
* Relax bounds for persistent 2.12
|
||||
|
||||
## 1.6.10.1
|
||||
|
||||
* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)
|
||||
|
||||
## 1.6.10
|
||||
|
||||
* Updated `AuthMessage` data type in `Yesod.Auth.Message` to accommodate registration flow where password is supplied initially: deprecated `AddressVerified` and split into `EmailVerifiedChangePass` and `EmailVerified`
|
||||
* Fixed a bug in `getVerifyR` related to the above, where the incorrect message was displayed when password was set during registration
|
||||
* Added `sendForgotPasswordEmail` to `YesodAuthEmail` typeclass, allowing for different emails for account registration vs. forgot password
|
||||
* See pull request [#1662](https://github.com/yesodweb/yesod/pull/1662)
|
||||
|
||||
## 1.6.9
|
||||
|
||||
* Added `registerHelper` and `passwordResetHelper` methods to the `YesodAuthEmail` class, allowing for customizing behavior for user registration and forgot password requests [#1660](https://github.com/yesodweb/yesod/pull/1660)
|
||||
* Exposed `defaultRegisterHelper` as default implementation for the above methods
|
||||
|
||||
## 1.6.8.1
|
||||
|
||||
* Email: Fix typo in `defaultEmailLoginHandler` template [#1605](https://github.com/yesodweb/yesod/pull/1605)
|
||||
* Remove unnecessary deriving of Typeable
|
||||
|
||||
## 1.6.8
|
||||
|
||||
* Dummy: Add support for JSON submissions [#1619](https://github.com/yesodweb/yesod/pull/1619)
|
||||
|
||||
## 1.6.7
|
||||
|
||||
* Redirect behavior of `clearCreds` depends on request type [#1598](https://github.com/yesodweb/yesod/pull/1598)
|
||||
|
||||
## 1.6.6
|
||||
|
||||
* Deprecated `Yesod.Auth.GoogleEmail2`, see [#1579](https://github.com/yesodweb/yesod/issues/1579) and [migration blog post](https://pbrisbin.com/posts/googleemail2_deprecation/)
|
||||
|
||||
## 1.6.5
|
||||
|
||||
* Add support for persistent 2.9 [#1516](https://github.com/yesodweb/yesod/pull/1516), [#1561](https://github.com/yesodweb/yesod/pull/1561)
|
||||
|
||||
## 1.6.4.1
|
||||
|
||||
* Email: Fix forgot-password endpoint [#1537](https://github.com/yesodweb/yesod/pull/1537)
|
||||
|
||||
## 1.6.4
|
||||
|
||||
* Make `registerHelper` configurable [#1524](https://github.com/yesodweb/yesod/issues/1524)
|
||||
* Email: Immediately register with a password [#1389](https://github.com/yesodweb/yesod/issues/1389)
|
||||
To configure this new functionality:
|
||||
1. Define `addUnverifiedWithPass`, e.g:
|
||||
```
|
||||
addUnverified email verkey = liftHandler $ runDB $ do
|
||||
void $ insert $ UserLogin email Nothing (Just verkey) False
|
||||
return email
|
||||
|
||||
addUnverifiedWithPass email verkey pass = liftHandler $ runDB $ do
|
||||
void $ insert $ UserLogin email (Just pass) (Just verkey) False
|
||||
return email
|
||||
```
|
||||
2. Add a `password` field to your client forms.
|
||||
|
||||
## 1.6.3
|
||||
|
||||
* Generalize GoogleEmail2.getPerson [#1501](https://github.com/yesodweb/yesod/pull/1501)
|
||||
|
||||
## 1.6.2
|
||||
|
||||
* Remove MINIMAL praggma for authHttpManager [#1489](https://github.com/yesodweb/yesod/issues/1489)
|
||||
|
||||
## 1.6.1
|
||||
|
||||
* Relax a number of type signatures [#1488](https://github.com/yesodweb/yesod/issues/1488)
|
||||
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
|
||||
## 1.4.21
|
||||
|
||||
* Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin [#1461](https://github.com/yesodweb/yesod/pull/1461)
|
||||
|
||||
## 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
|
||||
|
||||
@ -6,7 +6,6 @@ BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available
|
||||
from Hackage as well. If you've written such an add-on, please notify me so
|
||||
that it can be added to this description.
|
||||
|
||||
* [yesod-auth-oauth2](https://hackage.haskell.org/package/yesod-auth-oauth2): Library to authenticate with OAuth 2.0.
|
||||
* [yesod-auth-account](http://hackage.haskell.org/package/yesod-auth-account): An account authentication plugin for Yesod
|
||||
* [yesod-auth-hashdb](http://www.stackage.org/package/yesod-auth-hashdb): The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security.
|
||||
* [yesod-auth-bcrypt](https://hackage.haskell.org/package/yesod-auth-bcrypt): An alternative to the HashDB module.
|
||||
* [yesod-auth-bcrypt](https://github.com/ollieh/yesod-auth-bcrypt/): An alternative to the HashDB module.
|
||||
|
||||
@ -8,6 +8,7 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Yesod.Auth
|
||||
@ -38,7 +39,6 @@ module Yesod.Auth
|
||||
-- * Exception
|
||||
, AuthException (..)
|
||||
-- * Helper
|
||||
, MonadAuthHandler
|
||||
, AuthHandler
|
||||
-- * Internal
|
||||
, credsKey
|
||||
@ -47,11 +47,12 @@ module Yesod.Auth
|
||||
, asHtml
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.Trans.Maybe
|
||||
import UnliftIO (withRunInIO, MonadUnliftIO)
|
||||
|
||||
import Yesod.Auth.Routes
|
||||
import Data.Aeson hiding (json)
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Data.Text (Text)
|
||||
@ -59,11 +60,11 @@ import qualified Data.Text as T
|
||||
import qualified Data.HashMap.Lazy as Map
|
||||
import Data.Monoid (Endo)
|
||||
import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader)
|
||||
import Network.HTTP.Client.TLS (getGlobalManager)
|
||||
|
||||
import qualified Network.Wai as W
|
||||
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Types (HandlerT(..), unHandlerT)
|
||||
import Yesod.Persist
|
||||
import Yesod.Auth.Message (AuthMessage, defaultMessage)
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
@ -71,21 +72,20 @@ import Yesod.Form (FormMessage)
|
||||
import Data.Typeable (Typeable)
|
||||
import Control.Exception (Exception)
|
||||
import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
|
||||
import Control.Monad.Trans.Resource (MonadResourceBase)
|
||||
import qualified Control.Monad.Trans.Writer as Writer
|
||||
import Control.Monad (void)
|
||||
import Data.Kind (Type)
|
||||
|
||||
type AuthRoute = Route Auth
|
||||
|
||||
type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
|
||||
type AuthHandler master a = forall m. MonadAuthHandler master m => m a
|
||||
type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a
|
||||
|
||||
type Method = Text
|
||||
type Piece = Text
|
||||
|
||||
-- | The result of an authentication based on credentials
|
||||
--
|
||||
-- @since 1.4.4
|
||||
-- Since 1.4.4
|
||||
data AuthenticationResult master
|
||||
= Authenticated (AuthId master) -- ^ Authenticated successfully
|
||||
| UserError AuthMessage -- ^ Invalid credentials provided by user
|
||||
@ -94,7 +94,7 @@ data AuthenticationResult master
|
||||
data AuthPlugin master = AuthPlugin
|
||||
{ apName :: Text
|
||||
, apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
|
||||
, apLogin :: (Route Auth -> Route master) -> WidgetFor master ()
|
||||
, apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
|
||||
}
|
||||
|
||||
getAuth :: a -> Auth
|
||||
@ -105,14 +105,14 @@ data Creds master = Creds
|
||||
{ credsPlugin :: Text -- ^ How the user was authenticated
|
||||
, credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.
|
||||
, credsExtra :: [(Text, Text)]
|
||||
} deriving (Show)
|
||||
}
|
||||
|
||||
class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where
|
||||
type AuthId master
|
||||
|
||||
-- | specify the layout. Uses defaultLayout by default
|
||||
authLayout :: (MonadHandler m, HandlerSite m ~ master) => WidgetFor master () -> m Html
|
||||
authLayout = liftHandler . defaultLayout
|
||||
authLayout :: WidgetT master IO () -> HandlerT master IO Html
|
||||
authLayout = defaultLayout
|
||||
|
||||
-- | Default destination on successful login, if no other
|
||||
-- destination exists.
|
||||
@ -126,8 +126,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
|
||||
--
|
||||
-- Default implementation is in terms of @'getAuthId'@
|
||||
--
|
||||
-- @since: 1.4.4
|
||||
authenticate :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (AuthenticationResult master)
|
||||
-- Since: 1.4.4
|
||||
authenticate :: Creds master -> HandlerT master IO (AuthenticationResult master)
|
||||
authenticate creds = do
|
||||
muid <- getAuthId creds
|
||||
|
||||
@ -137,7 +137,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
|
||||
--
|
||||
-- Default implementation is in terms of @'authenticate'@
|
||||
--
|
||||
getAuthId :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (Maybe (AuthId master))
|
||||
getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master))
|
||||
getAuthId creds = do
|
||||
auth <- authenticate creds
|
||||
|
||||
@ -166,7 +166,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
|
||||
-- > when (isJust ma) $
|
||||
-- > lift $ redirect HomeR -- or any other Handler code you want
|
||||
-- > defaultLoginHandler
|
||||
--
|
||||
--
|
||||
loginHandler :: AuthHandler master Html
|
||||
loginHandler = defaultLoginHandler
|
||||
|
||||
@ -182,27 +182,19 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
|
||||
redirectToReferer :: master -> Bool
|
||||
redirectToReferer _ = False
|
||||
|
||||
-- | When being redirected to the login page should the current page
|
||||
-- be set to redirect back to. Default is 'True'.
|
||||
--
|
||||
-- @since 1.4.21
|
||||
redirectToCurrent :: master -> Bool
|
||||
redirectToCurrent _ = True
|
||||
|
||||
-- | Return an HTTP connection manager that is stored in the foundation
|
||||
-- type. This allows backends to reuse persistent connections. If none of
|
||||
-- the backends you're using use HTTP connections, you can safely return
|
||||
-- @error \"authHttpManager\"@ here.
|
||||
authHttpManager :: (MonadHandler m, HandlerSite m ~ master) => m Manager
|
||||
authHttpManager = liftIO getGlobalManager
|
||||
authHttpManager :: master -> Manager
|
||||
|
||||
-- | Called on a successful login. By default, calls
|
||||
-- @addMessageI "success" NowLoggedIn@.
|
||||
onLogin :: (MonadHandler m, master ~ HandlerSite m) => m ()
|
||||
onLogin :: HandlerT master IO ()
|
||||
onLogin = addMessageI "success" Msg.NowLoggedIn
|
||||
|
||||
-- | Called on logout. By default, does nothing
|
||||
onLogout :: (MonadHandler m, master ~ HandlerSite m) => m ()
|
||||
onLogout :: HandlerT master IO ()
|
||||
onLogout = return ()
|
||||
|
||||
-- | Retrieves user credentials, if user is authenticated.
|
||||
@ -213,17 +205,17 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
|
||||
-- especially useful for creating an API to be accessed via some means
|
||||
-- other than a browser.
|
||||
--
|
||||
-- @since 1.2.0
|
||||
maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master))
|
||||
-- Since 1.2.0
|
||||
maybeAuthId :: HandlerT master IO (Maybe (AuthId master))
|
||||
|
||||
default maybeAuthId
|
||||
:: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master))
|
||||
=> m (Maybe (AuthId master))
|
||||
:: (YesodAuthPersist master, Typeable (AuthEntity master))
|
||||
=> HandlerT master IO (Maybe (AuthId master))
|
||||
maybeAuthId = defaultMaybeAuthId
|
||||
|
||||
-- | Called on login error for HTTP requests. By default, calls
|
||||
-- @addMessage@ with "error" as status and redirects to @dest@.
|
||||
onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html
|
||||
onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html
|
||||
onErrorHtml dest msg = do
|
||||
addMessage "error" $ toHtml msg
|
||||
fmap asHtml $ redirect dest
|
||||
@ -233,35 +225,30 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
|
||||
--
|
||||
-- The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request.
|
||||
-- This is an experimental API that is not broadly used throughout the yesod-auth code base
|
||||
runHttpRequest
|
||||
:: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m)
|
||||
=> Request
|
||||
-> (Response BodyReader -> m a)
|
||||
-> m a
|
||||
runHttpRequest :: Request -> (Response BodyReader -> HandlerT master IO a) -> HandlerT master IO a
|
||||
runHttpRequest req inner = do
|
||||
man <- authHttpManager
|
||||
withRunInIO $ \run -> withResponse req man $ run . inner
|
||||
man <- authHttpManager <$> getYesod
|
||||
HandlerT $ \t -> withResponse req man $ \res -> unHandlerT (inner res) t
|
||||
|
||||
{-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins #-}
|
||||
{-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-}
|
||||
|
||||
{-# DEPRECATED getAuthId "Define 'authenticate' instead; 'getAuthId' will be removed in the next major version" #-}
|
||||
|
||||
-- | Internal session key used to hold the authentication information.
|
||||
--
|
||||
-- @since 1.2.3
|
||||
-- Since 1.2.3
|
||||
credsKey :: Text
|
||||
credsKey = "_ID"
|
||||
|
||||
-- | 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.
|
||||
-- 'maybeAuthIdRaw' for more information.
|
||||
--
|
||||
-- @since 1.1.2
|
||||
-- Since 1.1.2
|
||||
defaultMaybeAuthId
|
||||
:: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master))
|
||||
=> m (Maybe (AuthId master))
|
||||
:: (YesodAuthPersist master, Typeable (AuthEntity master))
|
||||
=> HandlerT master IO (Maybe (AuthId master))
|
||||
defaultMaybeAuthId = runMaybeT $ do
|
||||
s <- MaybeT $ lookupSession credsKey
|
||||
aid <- MaybeT $ return $ fromPathPiece s
|
||||
@ -269,13 +256,8 @@ defaultMaybeAuthId = runMaybeT $ do
|
||||
return aid
|
||||
|
||||
cachedAuth
|
||||
:: ( MonadHandler m
|
||||
, YesodAuthPersist master
|
||||
, Typeable (AuthEntity master)
|
||||
, HandlerSite m ~ master
|
||||
)
|
||||
=> AuthId master
|
||||
-> m (Maybe (AuthEntity master))
|
||||
:: (YesodAuthPersist master, Typeable (AuthEntity master))
|
||||
=> AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
|
||||
cachedAuth
|
||||
= fmap unCachedMaybeAuth
|
||||
. cached
|
||||
@ -288,59 +270,52 @@ cachedAuth
|
||||
-- This is the default 'loginHandler'. It concatenates plugin widgets and
|
||||
-- wraps the result in 'authLayout'. See 'loginHandler' for more details.
|
||||
--
|
||||
-- @since 1.4.9
|
||||
-- Since 1.4.9
|
||||
defaultLoginHandler :: AuthHandler master Html
|
||||
defaultLoginHandler = do
|
||||
tp <- getRouteToParent
|
||||
authLayout $ do
|
||||
lift $ authLayout $ do
|
||||
setTitleI Msg.LoginTitle
|
||||
master <- getYesod
|
||||
mapM_ (flip apLogin tp) (authPlugins master)
|
||||
|
||||
|
||||
loginErrorMessageI
|
||||
:: Route Auth
|
||||
-> AuthMessage
|
||||
-> AuthHandler master TypedContent
|
||||
loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)
|
||||
=> Route child
|
||||
-> AuthMessage
|
||||
-> HandlerT child (HandlerT master m) TypedContent
|
||||
loginErrorMessageI dest msg = do
|
||||
toParent <- getRouteToParent
|
||||
loginErrorMessageMasterI (toParent dest) msg
|
||||
lift $ loginErrorMessageMasterI (toParent dest) msg
|
||||
|
||||
|
||||
loginErrorMessageMasterI
|
||||
:: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)
|
||||
=> Route master
|
||||
-> AuthMessage
|
||||
-> m TypedContent
|
||||
loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)
|
||||
=> Route master
|
||||
-> AuthMessage
|
||||
-> HandlerT master 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)
|
||||
loginErrorMessage :: (YesodAuth master, MonadResourceBase m)
|
||||
=> Route master
|
||||
-> Text
|
||||
-> m TypedContent
|
||||
-> HandlerT master m TypedContent
|
||||
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
|
||||
|
||||
messageJson401
|
||||
:: MonadHandler m
|
||||
=> Text
|
||||
-> m Html
|
||||
-> m TypedContent
|
||||
messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
|
||||
messageJson401 = messageJsonStatus unauthorized401
|
||||
|
||||
messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent
|
||||
messageJson500 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
|
||||
messageJson500 = messageJsonStatus internalServerError500
|
||||
|
||||
messageJsonStatus
|
||||
:: MonadHandler m
|
||||
=> Status
|
||||
-> Text
|
||||
-> m Html
|
||||
-> m TypedContent
|
||||
messageJsonStatus :: MonadResourceBase m
|
||||
=> Status
|
||||
-> Text
|
||||
-> HandlerT master m Html
|
||||
-> HandlerT master m TypedContent
|
||||
messageJsonStatus status msg html = selectRep $ do
|
||||
provideRep html
|
||||
provideRep $ do
|
||||
@ -352,10 +327,9 @@ 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 :: YesodAuth master
|
||||
=> Creds master -- ^ new credentials
|
||||
-> HandlerT master IO TypedContent
|
||||
setCredsRedirect creds = do
|
||||
y <- getYesod
|
||||
auth <- authenticate creds
|
||||
@ -394,10 +368,10 @@ setCredsRedirect creds = do
|
||||
return $ renderAuthMessage master langs msg
|
||||
|
||||
-- | Sets user credentials for the session after checking them with authentication backends.
|
||||
setCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
|
||||
=> Bool -- ^ if HTTP redirects should be done
|
||||
-> Creds (HandlerSite m) -- ^ new credentials
|
||||
-> m ()
|
||||
setCreds :: YesodAuth master
|
||||
=> Bool -- ^ if HTTP redirects should be done
|
||||
-> Creds master -- ^ new credentials
|
||||
-> HandlerT master IO ()
|
||||
setCreds doRedirects creds =
|
||||
if doRedirects
|
||||
then void $ setCredsRedirect creds
|
||||
@ -407,36 +381,29 @@ setCreds doRedirects creds =
|
||||
_ -> return ()
|
||||
|
||||
-- | same as defaultLayoutJson, but uses authLayout
|
||||
authLayoutJson
|
||||
:: (ToJSON j, MonadAuthHandler master m)
|
||||
=> WidgetFor master () -- ^ HTML
|
||||
-> m j -- ^ JSON
|
||||
-> m TypedContent
|
||||
authLayoutJson :: (YesodAuth site, ToJSON j)
|
||||
=> WidgetT site IO () -- ^ HTML
|
||||
-> HandlerT site IO j -- ^ JSON
|
||||
-> HandlerT site IO 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 ()
|
||||
-- Since 1.1.7
|
||||
clearCreds :: YesodAuth master
|
||||
=> Bool -- ^ if HTTP redirect to 'logoutDest' should be done
|
||||
-> HandlerT master IO ()
|
||||
clearCreds doRedirects = do
|
||||
y <- getYesod
|
||||
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!"
|
||||
when doRedirects $ do
|
||||
redirectUltDest $ logoutDest y
|
||||
|
||||
getCheckR :: AuthHandler master TypedContent
|
||||
getCheckR = do
|
||||
getCheckR = lift $ do
|
||||
creds <- maybeAuthId
|
||||
authLayoutJson (do
|
||||
setTitle "Authentication Status"
|
||||
@ -452,12 +419,12 @@ $nothing
|
||||
<p>Not logged in.
|
||||
|]
|
||||
jsonCreds creds =
|
||||
toJSON $ Map.fromList
|
||||
Object $ Map.fromList
|
||||
[ (T.pack "logged_in", Bool $ maybe False (const True) creds)
|
||||
]
|
||||
|
||||
setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m ()
|
||||
setUltDestReferer' = do
|
||||
setUltDestReferer' :: AuthHandler master ()
|
||||
setUltDestReferer' = lift $ do
|
||||
master <- getYesod
|
||||
when (redirectToReferer master) setUltDestReferer
|
||||
|
||||
@ -465,16 +432,14 @@ getLoginR :: AuthHandler master Html
|
||||
getLoginR = setUltDestReferer' >> loginHandler
|
||||
|
||||
getLogoutR :: AuthHandler master ()
|
||||
getLogoutR = do
|
||||
tp <- getRouteToParent
|
||||
setUltDestReferer' >> redirectToPost (tp LogoutR)
|
||||
getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
|
||||
|
||||
postLogoutR :: AuthHandler master ()
|
||||
postLogoutR = clearCreds True
|
||||
postLogoutR = lift $ clearCreds True
|
||||
|
||||
handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
|
||||
handlePluginR plugin pieces = do
|
||||
master <- getYesod
|
||||
master <- lift getYesod
|
||||
env <- waiRequest
|
||||
let method = decodeUtf8With lenientDecode $ W.requestMethod env
|
||||
case filter (\x -> apName x == plugin) (authPlugins master) of
|
||||
@ -485,28 +450,23 @@ handlePluginR plugin pieces = do
|
||||
-- with the user\'s database identifier to get the value in the database. This
|
||||
-- assumes that you are using a Persistent database.
|
||||
--
|
||||
-- @since 1.1.0
|
||||
-- Since 1.1.0
|
||||
maybeAuth :: ( YesodAuthPersist master
|
||||
, val ~ AuthEntity master
|
||||
, Key val ~ AuthId master
|
||||
, PersistEntity val
|
||||
, Typeable val
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
) => m (Maybe (Entity val))
|
||||
maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
|
||||
) => HandlerT master IO (Maybe (Entity val))
|
||||
maybeAuth = runMaybeT $ do
|
||||
(aid, ae) <- MaybeT maybeAuthPair
|
||||
return $ Entity aid ae
|
||||
|
||||
-- | 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))
|
||||
-- Since 1.4.0
|
||||
maybeAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
|
||||
=> HandlerT master IO (Maybe (AuthId master, AuthEntity master))
|
||||
maybeAuthPair = runMaybeT $ do
|
||||
aid <- MaybeT maybeAuthId
|
||||
ae <- MaybeT $ cachedAuth aid
|
||||
@ -514,6 +474,7 @@ maybeAuthPair = runMaybeT $ do
|
||||
|
||||
|
||||
newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
|
||||
deriving Typeable
|
||||
|
||||
-- | Class which states that the given site is an instance of @YesodAuth@
|
||||
-- and that its @AuthId@ is a lookup key for the full user information in
|
||||
@ -524,7 +485,7 @@ newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
|
||||
-- given value. This is the common case in Yesod, and means that you can
|
||||
-- easily look up the full information on a given user.
|
||||
--
|
||||
-- @since 1.4.0
|
||||
-- Since 1.4.0
|
||||
class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
|
||||
-- | If the @AuthId@ for a given site is a persistent ID, this will give the
|
||||
-- value for that entity. E.g.:
|
||||
@ -532,23 +493,31 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
|
||||
-- > type AuthId MySite = UserId
|
||||
-- > AuthEntity MySite ~ User
|
||||
--
|
||||
-- @since 1.2.0
|
||||
type AuthEntity master :: Type
|
||||
-- Since 1.2.0
|
||||
type AuthEntity master :: *
|
||||
type AuthEntity master = KeyEntity (AuthId master)
|
||||
|
||||
getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)
|
||||
=> AuthId master -> m (Maybe (AuthEntity master))
|
||||
getAuthEntity :: AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
|
||||
|
||||
#if MIN_VERSION_persistent(2,5,0)
|
||||
default getAuthEntity
|
||||
:: ( YesodPersistBackend master ~ backend
|
||||
, PersistRecordBackend (AuthEntity master) backend
|
||||
, Key (AuthEntity master) ~ AuthId master
|
||||
, PersistStore backend
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
)
|
||||
=> AuthId master -> m (Maybe (AuthEntity master))
|
||||
getAuthEntity = liftHandler . runDB . get
|
||||
=> AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
|
||||
#else
|
||||
default getAuthEntity
|
||||
:: ( YesodPersistBackend master
|
||||
~ PersistEntityBackend (AuthEntity master)
|
||||
, Key (AuthEntity master) ~ AuthId master
|
||||
, PersistStore (YesodPersistBackend master)
|
||||
, PersistEntity (AuthEntity master)
|
||||
)
|
||||
=> AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
|
||||
#endif
|
||||
getAuthEntity = runDB . get
|
||||
|
||||
|
||||
type family KeyEntity key
|
||||
@ -557,46 +526,39 @@ 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))
|
||||
-- Since 1.1.0
|
||||
requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master)
|
||||
requireAuthId = maybeAuthId >>= maybe handleAuthLack return
|
||||
|
||||
-- | Similar to 'maybeAuth', but redirects to a login page if user is not
|
||||
-- authenticated or responds with error 401 if this is an API client (expecting JSON).
|
||||
--
|
||||
-- @since 1.1.0
|
||||
-- Since 1.1.0
|
||||
requireAuth :: ( YesodAuthPersist master
|
||||
, val ~ AuthEntity master
|
||||
, Key val ~ AuthId master
|
||||
, PersistEntity val
|
||||
, Typeable val
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
) => m (Entity val)
|
||||
) => HandlerT master IO (Entity val)
|
||||
requireAuth = maybeAuth >>= maybe handleAuthLack return
|
||||
|
||||
-- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
|
||||
-- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple.
|
||||
--
|
||||
-- @since 1.4.0
|
||||
requireAuthPair
|
||||
:: ( YesodAuthPersist master
|
||||
, Typeable (AuthEntity master)
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
)
|
||||
=> m (AuthId master, AuthEntity master)
|
||||
-- Since 1.4.0
|
||||
requireAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
|
||||
=> HandlerT master IO (AuthId master, AuthEntity master)
|
||||
requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return
|
||||
|
||||
handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
|
||||
handleAuthLack :: Yesod master => HandlerT master IO a
|
||||
handleAuthLack = do
|
||||
aj <- acceptsJson
|
||||
if aj then notAuthenticated else redirectLogin
|
||||
|
||||
redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
|
||||
redirectLogin :: Yesod master => HandlerT master IO a
|
||||
redirectLogin = do
|
||||
y <- getYesod
|
||||
when (redirectToCurrent y) setUltDestCurrent
|
||||
setUltDestCurrent
|
||||
case authRoute y of
|
||||
Just z -> redirect z
|
||||
Nothing -> permissionDenied "Please configure authRoute"
|
||||
@ -605,10 +567,10 @@ instance YesodAuth master => RenderMessage master AuthMessage where
|
||||
renderMessage = renderAuthMessage
|
||||
|
||||
data AuthException = InvalidFacebookResponse
|
||||
deriving Show
|
||||
deriving (Show, Typeable)
|
||||
instance Exception AuthException
|
||||
|
||||
instance YesodAuth master => YesodSubDispatch Auth master where
|
||||
instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
|
||||
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
|
||||
|
||||
asHtml :: Html -> Html
|
||||
|
||||
@ -70,21 +70,20 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
|
||||
, apDispatch = \m ps ->
|
||||
case (m, ps) of
|
||||
("GET", [assertion]) -> do
|
||||
master <- lift getYesod
|
||||
audience <-
|
||||
case bisAudience of
|
||||
Just a -> return a
|
||||
Nothing -> do
|
||||
r <- getUrlRender
|
||||
tm <- getRouteToParent
|
||||
return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
|
||||
manager <- authHttpManager
|
||||
memail <- checkAssertion audience assertion manager
|
||||
return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR
|
||||
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
|
||||
lift $ loginErrorMessage (tm LoginR) "BrowserID login error."
|
||||
Just email -> lift $ setCredsRedirect Creds
|
||||
{ credsPlugin = pid
|
||||
, credsIdent = email
|
||||
, credsExtra = []
|
||||
@ -117,7 +116,7 @@ $newline never
|
||||
createOnClickOverride :: BrowserIdSettings
|
||||
-> (Route Auth -> Route master)
|
||||
-> Maybe (Route master)
|
||||
-> WidgetFor master Text
|
||||
-> WidgetT master IO Text
|
||||
createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
|
||||
unless bisLazyLoad $ addScriptRemote browserIdJs
|
||||
onclick <- newIdent
|
||||
@ -166,5 +165,5 @@ createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
|
||||
-- name.
|
||||
createOnClick :: BrowserIdSettings
|
||||
-> (Route Auth -> Route master)
|
||||
-> WidgetFor master Text
|
||||
-> WidgetT master IO Text
|
||||
createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing
|
||||
|
||||
@ -1,67 +1,23 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# 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)
|
||||
|
||||
identParser :: Value -> Parser Text
|
||||
identParser = A.withObject "Ident" (.: "ident")
|
||||
import Yesod.Auth
|
||||
import Yesod.Form (runInputPost, textField, ireq)
|
||||
import Yesod.Core
|
||||
|
||||
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 <- lift $ runInputPost $ ireq textField "ident"
|
||||
lift $ setCredsRedirect $ Creds "dummy" ident []
|
||||
dispatch _ _ = notFound
|
||||
url = PluginR "dummy" []
|
||||
login authToMaster = do
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
89
yesod-auth/Yesod/Auth/GoogleEmail.hs
Normal file
89
yesod-auth/Yesod/Auth/GoogleEmail.hs
Normal file
@ -0,0 +1,89 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
-- | Use an email address as an identifier via Google's OpenID login system.
|
||||
--
|
||||
-- This backend will not use the OpenID identifier at all. It only uses OpenID
|
||||
-- as a login system. By using this plugin, you are trusting Google to validate
|
||||
-- an email address, and requiring users to have a Google account. On the plus
|
||||
-- side, you get to use email addresses as the identifier, many users have
|
||||
-- existing Google accounts, the login system has been long tested (as opposed
|
||||
-- to BrowserID), and it requires no credential managing or setup (as opposed
|
||||
-- to Email).
|
||||
module Yesod.Auth.GoogleEmail
|
||||
{-# DEPRECATED "Google no longer provides OpenID support, please use Yesod.Auth.GoogleEmail2" #-}
|
||||
( authGoogleEmail
|
||||
, forwardUrl
|
||||
) where
|
||||
|
||||
import Yesod.Auth
|
||||
import qualified Web.Authenticate.OpenId as OpenId
|
||||
|
||||
import Yesod.Core
|
||||
import Data.Text (Text)
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Lifted (try, SomeException)
|
||||
|
||||
pid :: Text
|
||||
pid = "googleemail"
|
||||
|
||||
forwardUrl :: AuthRoute
|
||||
forwardUrl = PluginR pid ["forward"]
|
||||
|
||||
googleIdent :: Text
|
||||
googleIdent = "https://www.google.com/accounts/o8/id"
|
||||
|
||||
authGoogleEmail :: YesodAuth m => AuthPlugin m
|
||||
authGoogleEmail =
|
||||
AuthPlugin pid dispatch login
|
||||
where
|
||||
complete = PluginR pid ["complete"]
|
||||
login tm =
|
||||
[whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
|
||||
dispatch "GET" ["forward"] = do
|
||||
render <- getUrlRender
|
||||
let complete' = render complete
|
||||
master <- lift getYesod
|
||||
eres <- lift $ try $ OpenId.getForwardUrl googleIdent complete' Nothing
|
||||
[ ("openid.ax.type.email", "http://schema.openid.net/contact/email")
|
||||
, ("openid.ns.ax", "http://openid.net/srv/ax/1.0")
|
||||
, ("openid.ns.ax.required", "email")
|
||||
, ("openid.ax.mode", "fetch_request")
|
||||
, ("openid.ax.required", "email")
|
||||
, ("openid.ui.icon", "true")
|
||||
] (authHttpManager master)
|
||||
either
|
||||
(\err -> do
|
||||
tm <- getRouteToParent
|
||||
lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException))
|
||||
redirect
|
||||
eres
|
||||
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
|
||||
dispatch "GET" ["complete"] = do
|
||||
rr <- getRequest
|
||||
completeHelper $ reqGetParams rr
|
||||
dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues
|
||||
dispatch "POST" ["complete"] = do
|
||||
(posts, _) <- runRequestBody
|
||||
completeHelper posts
|
||||
dispatch _ _ = notFound
|
||||
|
||||
completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master TypedContent
|
||||
completeHelper gets' = do
|
||||
master <- lift getYesod
|
||||
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
|
||||
tm <- getRouteToParent
|
||||
either (onFailure tm) (onSuccess tm) eres
|
||||
where
|
||||
onFailure tm err =
|
||||
lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)
|
||||
onSuccess tm oir = do
|
||||
let OpenId.Identifier ident = OpenId.oirOpLocal oir
|
||||
memail <- lookupGetParam "openid.ext1.value.email"
|
||||
case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
|
||||
(Just email, True) -> lift $ setCredsRedirect $ Creds pid email []
|
||||
(_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"
|
||||
(Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"
|
||||
@ -1,9 +1,6 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
-- | Use an email address as an identifier via Google's login system.
|
||||
--
|
||||
-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends
|
||||
@ -24,9 +21,8 @@
|
||||
--
|
||||
-- * Enable the Google+ API.
|
||||
--
|
||||
-- @since 1.3.1
|
||||
-- Since 1.3.1
|
||||
module Yesod.Auth.GoogleEmail2
|
||||
{-# DEPRECATED "Google+ is being shut down, please migrate to Google Sign-in https://pbrisbin.com/posts/googleemail2_deprecation/" #-}
|
||||
( -- * Authentication handlers
|
||||
authGoogleEmail
|
||||
, authGoogleEmailSaveToken
|
||||
@ -49,71 +45,54 @@ module Yesod.Auth.GoogleEmail2
|
||||
, 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 Yesod.Auth (Auth, AuthPlugin (AuthPlugin),
|
||||
AuthRoute, Creds (Creds),
|
||||
Route (PluginR), YesodAuth,
|
||||
runHttpRequest, setCredsRedirect,
|
||||
logoutDest)
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
import Yesod.Core (HandlerSite, HandlerT, MonadHandler,
|
||||
TypedContent, getRouteToParent,
|
||||
getUrlRender, invalidArgs,
|
||||
lift, liftIO, lookupGetParam,
|
||||
lookupSession, notFound, redirect,
|
||||
setSession, whamlet, (.:),
|
||||
addMessage, getYesod, authRoute,
|
||||
toHtml)
|
||||
|
||||
|
||||
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 Blaze.ByteString.Builder (fromByteString, toByteString)
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Control.Arrow (second)
|
||||
import Control.Monad (unless, when)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import qualified Crypto.Nonce as Nonce
|
||||
import Data.Aeson ((.:?))
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.Encode as A
|
||||
import Data.Aeson.Parser (json')
|
||||
import Data.Aeson.Types (FromJSON (parseJSON), parseEither,
|
||||
parseMaybe, withObject, withText)
|
||||
import Data.Conduit (($$+-), ($$))
|
||||
import Data.Conduit.Attoparsec (sinkParser)
|
||||
import qualified Data.HashMap.Strict as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Monoid (mappend)
|
||||
import Data.Text (Text)
|
||||
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, parseUrl, requestHeaders,
|
||||
responseBody, urlEncodedBody)
|
||||
import Network.HTTP.Client.Conduit (Request, bodyReaderSource)
|
||||
import Network.HTTP.Conduit (http)
|
||||
import Network.HTTP.Types (renderQueryText)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
#if MIN_VERSION_aeson(2, 0, 0)
|
||||
import qualified Data.Aeson.Key
|
||||
import qualified Data.Aeson.KeyMap
|
||||
#else
|
||||
import qualified Data.HashMap.Strict as M
|
||||
#endif
|
||||
import Network.HTTP.Conduit (http)
|
||||
import Network.HTTP.Types (renderQueryText)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
|
||||
-- | Plugin identifier. This is used to identify the plugin used for
|
||||
-- authentication. The 'credsPlugin' will contain this value when this
|
||||
-- plugin is used for authentication.
|
||||
-- @since 1.4.17
|
||||
pid :: Text
|
||||
pid = "googleemail2"
|
||||
|
||||
@ -154,7 +133,7 @@ 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
|
||||
-- Since 1.4.3
|
||||
authGoogleEmailSaveToken :: YesodAuth m
|
||||
=> Text -- ^ client ID
|
||||
-> Text -- ^ client secret
|
||||
@ -188,7 +167,7 @@ authPlugin storeToken clientID clientSecret =
|
||||
return $ decodeUtf8
|
||||
$ toByteString
|
||||
$ fromByteString "https://accounts.google.com/o/oauth2/auth"
|
||||
`Data.Monoid.mappend` renderQueryText True qs
|
||||
`mappend` renderQueryText True qs
|
||||
|
||||
login tm = do
|
||||
[whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
|
||||
@ -196,10 +175,10 @@ authPlugin storeToken clientID clientSecret =
|
||||
dispatch :: YesodAuth site
|
||||
=> Text
|
||||
-> [Text]
|
||||
-> AuthHandler site TypedContent
|
||||
-> HandlerT Auth (HandlerT site IO) TypedContent
|
||||
dispatch "GET" ["forward"] = do
|
||||
tm <- getRouteToParent
|
||||
getDest tm >>= redirect
|
||||
lift (getDest tm) >>= redirect
|
||||
|
||||
dispatch "GET" ["complete"] = do
|
||||
mstate <- lookupGetParam "state"
|
||||
@ -216,27 +195,24 @@ authPlugin storeToken clientID clientSecret =
|
||||
case merr of
|
||||
Nothing -> invalidArgs ["Missing code paramter"]
|
||||
Just err -> do
|
||||
master <- getYesod
|
||||
master <- lift getYesod
|
||||
let msg =
|
||||
case err of
|
||||
"access_denied" -> "Access denied"
|
||||
_ -> "Unknown error occurred: " `T.append` err
|
||||
addMessage "error" $ toHtml msg
|
||||
redirect $ logoutDest master
|
||||
lift $ redirect $ logoutDest master
|
||||
Just c -> return c
|
||||
|
||||
render <- getUrlRender
|
||||
tm <- getRouteToParent
|
||||
|
||||
req' <- liftIO $
|
||||
HTTP.parseUrlThrow
|
||||
"https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
|
||||
req' <- liftIO $ parseUrl "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
|
||||
let req =
|
||||
urlEncodedBody
|
||||
[ ("code", encodeUtf8 code)
|
||||
, ("client_id", encodeUtf8 clientID)
|
||||
, ("client_secret", encodeUtf8 clientSecret)
|
||||
, ("redirect_uri", encodeUtf8 $ render $ tm complete)
|
||||
, ("redirect_uri", encodeUtf8 $ render complete)
|
||||
, ("grant_type", "authorization_code")
|
||||
]
|
||||
req'
|
||||
@ -245,7 +221,7 @@ authPlugin storeToken clientID clientSecret =
|
||||
value <- makeHttpRequest req
|
||||
token@(Token accessToken' tokenType') <-
|
||||
case parseEither parseJSON value of
|
||||
Left e -> error e
|
||||
Left e -> error e
|
||||
Right t -> return t
|
||||
|
||||
unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType'
|
||||
@ -253,43 +229,42 @@ authPlugin storeToken clientID clientSecret =
|
||||
-- User's access token is saved for further access to API
|
||||
when storeToken $ setSession accessTokenKey accessToken'
|
||||
|
||||
personValReq <- personValueRequest token
|
||||
personValue <- makeHttpRequest personValReq
|
||||
|
||||
personValue <- makeHttpRequest =<< personValueRequest token
|
||||
person <- case parseEither parseJSON personValue of
|
||||
Left e -> error e
|
||||
Left e -> error e
|
||||
Right x -> return x
|
||||
|
||||
email <-
|
||||
case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of
|
||||
[e] -> return e
|
||||
[] -> error "No account email"
|
||||
x -> error $ "Too many account emails: " ++ show x
|
||||
setCredsRedirect $ Creds pid email $ allPersonInfo personValue
|
||||
[] -> error "No account email"
|
||||
x -> error $ "Too many account emails: " ++ show x
|
||||
lift $ 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'
|
||||
makeHttpRequest
|
||||
:: (YesodAuth site)
|
||||
=> Request
|
||||
-> HandlerT Auth (HandlerT site IO) A.Value
|
||||
makeHttpRequest req = lift $
|
||||
runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json'
|
||||
|
||||
-- | Allows to fetch information about a user from Google's API.
|
||||
-- In case of parsing error returns 'Nothing'.
|
||||
-- Will throw 'HttpException' in case of network problems or error response code.
|
||||
--
|
||||
-- @since 1.4.3
|
||||
getPerson :: MonadHandler m => Manager -> Token -> m (Maybe Person)
|
||||
getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do
|
||||
-- Since 1.4.3
|
||||
getPerson :: Manager -> Token -> HandlerT site IO (Maybe Person)
|
||||
getPerson manager token = parseMaybe parseJSON <$> (do
|
||||
req <- personValueRequest token
|
||||
res <- http req manager
|
||||
runConduit $ responseBody res .| sinkParser json'
|
||||
responseBody res $$+- sinkParser json'
|
||||
)
|
||||
|
||||
personValueRequest :: MonadIO m => Token -> m Request
|
||||
personValueRequest token = do
|
||||
req2' <- liftIO
|
||||
$ HTTP.parseUrlThrow "https://www.googleapis.com/plus/v1/people/me"
|
||||
req2' <- liftIO $ parseUrl "https://www.googleapis.com/plus/v1/people/me"
|
||||
return req2'
|
||||
{ requestHeaders =
|
||||
[ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)
|
||||
@ -302,20 +277,20 @@ personValueRequest token = do
|
||||
-- 'authGoogleEmailSaveToken'.
|
||||
-- You can acquire saved token with 'getUserAccessToken'.
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- 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"
|
||||
<$> o .: "access_token"
|
||||
<*> o .: "token_type"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Gender of the person
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- Since 1.4.3
|
||||
data Gender = Male | Female | OtherGender deriving (Show, Eq)
|
||||
|
||||
instance FromJSON Gender where
|
||||
@ -327,7 +302,7 @@ instance FromJSON Gender where
|
||||
--------------------------------------------------------------------------------
|
||||
-- | URIs specified in the person's profile
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- Since 1.4.3
|
||||
data PersonURI =
|
||||
PersonURI { uriLabel :: Maybe Text
|
||||
, uriValue :: Maybe Text
|
||||
@ -342,7 +317,7 @@ instance FromJSON PersonURI where
|
||||
--------------------------------------------------------------------------------
|
||||
-- | The type of URI
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- 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
|
||||
@ -361,7 +336,7 @@ instance FromJSON PersonURIType where
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Current or past organizations with which this person is associated
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- Since 1.4.3
|
||||
data Organization =
|
||||
Organization { orgName :: Maybe Text
|
||||
-- ^ The person's job title or role within the organization
|
||||
@ -388,7 +363,7 @@ instance FromJSON Organization where
|
||||
--------------------------------------------------------------------------------
|
||||
-- | The type of an organization
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- Since 1.4.3
|
||||
data OrganizationType = Work
|
||||
| School
|
||||
| OrganizationType Text -- ^ Something else
|
||||
@ -402,7 +377,7 @@ instance FromJSON OrganizationType where
|
||||
--------------------------------------------------------------------------------
|
||||
-- | A place where the person has lived or is living at the moment.
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- Since 1.4.3
|
||||
data Place =
|
||||
Place { -- | A place where this person has lived. For example: "Seattle, WA", "Near Toronto".
|
||||
placeValue :: Maybe Text
|
||||
@ -416,7 +391,7 @@ instance FromJSON Place where
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Individual components of a name
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- Since 1.4.3
|
||||
data Name =
|
||||
Name { -- | The full name of this person, including middle names, suffixes, etc
|
||||
nameFormatted :: Maybe Text
|
||||
@ -443,7 +418,7 @@ instance FromJSON Name where
|
||||
--------------------------------------------------------------------------------
|
||||
-- | The person's relationship status.
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- Since 1.4.3
|
||||
data RelationshipStatus = Single -- ^ Person is single
|
||||
| InRelationship -- ^ Person is in a relationship
|
||||
| Engaged -- ^ Person is engaged
|
||||
@ -458,21 +433,21 @@ data RelationshipStatus = Single -- ^ Person is single
|
||||
|
||||
instance FromJSON RelationshipStatus where
|
||||
parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of
|
||||
"single" -> Single
|
||||
"in_a_relationship" -> InRelationship
|
||||
"engaged" -> Engaged
|
||||
"married" -> Married
|
||||
"its_complicated" -> Complicated
|
||||
"open_relationship" -> OpenRelationship
|
||||
"widowed" -> Widowed
|
||||
"in_domestic_partnership" -> DomesticPartnership
|
||||
"in_civil_union" -> CivilUnion
|
||||
_ -> RelationshipStatus t
|
||||
"single" -> Single
|
||||
"in_a_relationship" -> InRelationship
|
||||
"engaged" -> Engaged
|
||||
"married" -> Married
|
||||
"its_complicated" -> Complicated
|
||||
"open_relationship" -> OpenRelationship
|
||||
"widowed" -> Widowed
|
||||
"in_domestic_partnership" -> DomesticPartnership
|
||||
"in_civil_union" -> CivilUnion
|
||||
_ -> RelationshipStatus t
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | The URI of the person's profile photo.
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- Since 1.4.3
|
||||
newtype PersonImage = PersonImage { imageUri :: Text } deriving (Show, Eq)
|
||||
|
||||
instance FromJSON PersonImage where
|
||||
@ -482,7 +457,7 @@ instance FromJSON PersonImage where
|
||||
-- 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
|
||||
-- Since 1.4.3
|
||||
resizePersonImage :: PersonImage -> Int -> PersonImage
|
||||
resizePersonImage (PersonImage uri) size =
|
||||
PersonImage $ uri `mappend` "?sz=" `mappend` T.pack (show size)
|
||||
@ -491,7 +466,7 @@ resizePersonImage (PersonImage uri) size =
|
||||
-- | Information about the user
|
||||
-- Full description of the resource https://developers.google.com/+/api/latest/people
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- Since 1.4.3
|
||||
data Person = Person
|
||||
{ personId :: Text
|
||||
-- | The name of this person, which is suitable for display
|
||||
@ -561,7 +536,7 @@ instance FromJSON Person where
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Person's email
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- Since 1.4.3
|
||||
data Email = Email
|
||||
{ emailValue :: Text
|
||||
, emailType :: EmailType
|
||||
@ -576,7 +551,7 @@ instance FromJSON Email where
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Type of email
|
||||
--
|
||||
-- @since 1.4.3
|
||||
-- Since 1.4.3
|
||||
data EmailType = EmailAccount -- ^ Google account email address
|
||||
| EmailHome -- ^ Home email address
|
||||
| EmailWork -- ^ Work email adress
|
||||
@ -593,19 +568,9 @@ instance FromJSON EmailType where
|
||||
_ -> EmailType t
|
||||
|
||||
allPersonInfo :: A.Value -> [(Text, Text)]
|
||||
allPersonInfo (A.Object o) = map enc $ mapToList o
|
||||
where
|
||||
enc (key, A.String s) = (keyToText key, s)
|
||||
enc (key, v) = (keyToText key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
|
||||
|
||||
#if MIN_VERSION_aeson(2, 0, 0)
|
||||
keyToText = Data.Aeson.Key.toText
|
||||
mapToList = Data.Aeson.KeyMap.toList
|
||||
#else
|
||||
keyToText = id
|
||||
mapToList = M.toList
|
||||
#endif
|
||||
|
||||
allPersonInfo (A.Object o) = map enc $ M.toList o
|
||||
where enc (key, A.String s) = (key, s)
|
||||
enc (key, v) = (key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
|
||||
allPersonInfo _ = []
|
||||
|
||||
|
||||
|
||||
@ -52,7 +52,7 @@ be unique).
|
||||
'AuthId' must have an instance of 'PathPiece' class, this is needed to store
|
||||
user identifier in session (this happens in 'setCreds' and 'setCredsRedirect'
|
||||
actions) and to read that identifier from session (this happens in
|
||||
`defaultMaybeAuthId` action). So we have to define it:
|
||||
`dafaultMaybeAuthId` action). So we have to define it:
|
||||
|
||||
@
|
||||
import Text.Read (readMaybe)
|
||||
@ -85,7 +85,7 @@ Here @lookupUser@ is just a helper function to lookup hardcoded users by name:
|
||||
|
||||
@
|
||||
lookupUser :: Text -> Maybe SiteManager
|
||||
lookupUser username = find (\\m -> manUserName m == username) siteManagers
|
||||
lookupUser username = find (\m -> manUserName m == username) siteManagers
|
||||
@
|
||||
|
||||
|
||||
@ -113,7 +113,7 @@ instance YesodAuthHardcoded App where
|
||||
|
||||
validPassword :: Text -> Text -> Bool
|
||||
validPassword u p =
|
||||
case find (\\m -> manUserName m == u && manPassWord m == p) siteManagers of
|
||||
case find (\m -> manUserName m == u && manPassWord m == p) siteManagers of
|
||||
Just _ -> True
|
||||
_ -> False
|
||||
@
|
||||
@ -131,7 +131,7 @@ module Yesod.Auth.Hardcoded
|
||||
, loginR )
|
||||
where
|
||||
|
||||
import Yesod.Auth (AuthHandler, AuthPlugin (..), AuthRoute,
|
||||
import Yesod.Auth (Auth, AuthPlugin (..), AuthRoute,
|
||||
Creds (..), Route (..), YesodAuth,
|
||||
loginErrorMessageI, setCredsRedirect)
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
@ -148,19 +148,18 @@ loginR = PluginR "hardcoded" ["login"]
|
||||
class (YesodAuth site) => YesodAuthHardcoded site where
|
||||
|
||||
-- | Check whether given user name exists among hardcoded names.
|
||||
doesUserNameExist :: Text -> AuthHandler site Bool
|
||||
doesUserNameExist :: Text -> HandlerT site IO Bool
|
||||
|
||||
-- | Validate given user name with given password.
|
||||
validatePassword :: Text -> Text -> AuthHandler site Bool
|
||||
validatePassword :: Text -> Text -> HandlerT site IO Bool
|
||||
|
||||
|
||||
authHardcoded :: YesodAuthHardcoded m => AuthPlugin m
|
||||
authHardcoded =
|
||||
AuthPlugin "hardcoded" dispatch loginWidget
|
||||
where
|
||||
dispatch :: YesodAuthHardcoded m => Text -> [Text] -> AuthHandler m TypedContent
|
||||
dispatch "POST" ["login"] = postLoginR >>= sendResponse
|
||||
dispatch _ _ = notFound
|
||||
dispatch _ _ = notFound
|
||||
loginWidget toMaster = do
|
||||
request <- getRequest
|
||||
[whamlet|
|
||||
@ -183,16 +182,16 @@ authHardcoded =
|
||||
|]
|
||||
|
||||
|
||||
postLoginR :: YesodAuthHardcoded site
|
||||
=> AuthHandler site TypedContent
|
||||
postLoginR :: (YesodAuthHardcoded master)
|
||||
=> HandlerT Auth (HandlerT master IO) TypedContent
|
||||
postLoginR =
|
||||
do (username, password) <- runInputPost
|
||||
((,) Control.Applicative.<$> ireq textField "username"
|
||||
Control.Applicative.<*> ireq textField "password")
|
||||
isValid <- validatePassword username password
|
||||
do (username, password) <- lift (runInputPost
|
||||
((,) <$> ireq textField "username"
|
||||
<*> ireq textField "password"))
|
||||
isValid <- lift (validatePassword username password)
|
||||
if isValid
|
||||
then setCredsRedirect (Creds "hardcoded" username [])
|
||||
else do isExists <- doesUserNameExist username
|
||||
then lift (setCredsRedirect (Creds "hardcoded" username []))
|
||||
else do isExists <- lift (doesUserNameExist username)
|
||||
loginErrorMessageI LoginR
|
||||
(if isExists
|
||||
then Msg.InvalidUsernamePass
|
||||
|
||||
@ -13,13 +13,11 @@ module Yesod.Auth.Message
|
||||
, japaneseMessage
|
||||
, finnishMessage
|
||||
, chineseMessage
|
||||
, croatianMessage
|
||||
, spanishMessage
|
||||
, czechMessage
|
||||
, russianMessage
|
||||
, dutchMessage
|
||||
, danishMessage
|
||||
, koreanMessage
|
||||
) where
|
||||
|
||||
import Data.Monoid (mappend, (<>))
|
||||
@ -40,8 +38,6 @@ data AuthMessage =
|
||||
| ConfirmationEmailSentTitle
|
||||
| ConfirmationEmailSent Text
|
||||
| AddressVerified
|
||||
| EmailVerifiedChangePass
|
||||
| EmailVerified
|
||||
| InvalidKeyTitle
|
||||
| InvalidKey
|
||||
| InvalidEmailPass
|
||||
@ -71,7 +67,6 @@ data AuthMessage =
|
||||
| LogoutTitle
|
||||
| AuthError
|
||||
{-# DEPRECATED Logout "Please, use LogoutTitle instead." #-}
|
||||
{-# DEPRECATED AddressVerified "Please, use EmailVerifiedChangePass instead." #-}
|
||||
|
||||
-- | Defaults to 'englishMessage'.
|
||||
defaultMessage :: AuthMessage -> Text
|
||||
@ -79,9 +74,9 @@ 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"
|
||||
@ -91,12 +86,10 @@ 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,8 +100,8 @@ 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"
|
||||
@ -144,8 +137,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"
|
||||
@ -182,7 +173,7 @@ spanishMessage LoginOpenID = "Entrar utilizando OpenID"
|
||||
spanishMessage LoginGoogle = "Entrar utilizando Google"
|
||||
spanishMessage LoginYahoo = "Entrar utilizando Yahoo"
|
||||
spanishMessage Email = "Correo electrónico"
|
||||
spanishMessage UserName = "Nombre de Usuario"
|
||||
spanishMessage UserName = "Nombre de Usuario" -- FIXME by Google Translate "user name"
|
||||
spanishMessage Password = "Contraseña"
|
||||
spanishMessage CurrentPassword = "Contraseña actual"
|
||||
spanishMessage Register = "Registrarse"
|
||||
@ -194,8 +185,6 @@ spanishMessage (ConfirmationEmailSent email) =
|
||||
email `mappend`
|
||||
"."
|
||||
spanishMessage AddressVerified = "Dirección verificada, por favor introduzca una contraseña"
|
||||
spanishMessage EmailVerifiedChangePass = "Dirección verificada, por favor introduzca una contraseña"
|
||||
spanishMessage EmailVerified = "Dirección verificada"
|
||||
spanishMessage InvalidKeyTitle = "Clave de verificación invalida"
|
||||
spanishMessage InvalidKey = "Lo sentimos, pero esa clave de verificación es inválida."
|
||||
spanishMessage InvalidEmailPass = "La combinación cuenta de correo/contraseña es inválida"
|
||||
@ -215,9 +204,9 @@ spanishMessage PleaseProvideUsername = "Por favor escriba su nombre de usuario"
|
||||
spanishMessage PleaseProvidePassword = "Por favor escriba su contraseña"
|
||||
spanishMessage NoIdentifierProvided = "No ha indicado una cuenta de correo/nombre de usuario"
|
||||
spanishMessage InvalidEmailAddress = "La cuenta de correo es inválida"
|
||||
spanishMessage PasswordResetTitle = "Actualización de contraseña"
|
||||
spanishMessage PasswordResetTitle = "Contraseña actualizada"
|
||||
spanishMessage ProvideIdentifier = "Cuenta de correo o nombre de usuario"
|
||||
spanishMessage SendPasswordResetEmail = "Enviar correo de actualización de contraseña"
|
||||
spanishMessage SendPasswordResetEmail = "Correo de actualización de contraseña enviado"
|
||||
spanishMessage PasswordResetPrompt = "Escriba su cuenta de correo o nombre de usuario, y una confirmación de actualización de contraseña será enviada a su cuenta de correo."
|
||||
spanishMessage InvalidUsernamePass = "Combinación de nombre de usuario/contraseña invalida"
|
||||
-- TODO
|
||||
@ -244,8 +233,6 @@ swedishMessage (ConfirmationEmailSent email) =
|
||||
email `mappend`
|
||||
"."
|
||||
swedishMessage AddressVerified = "Adress verifierad, vänligen välj nytt lösenord"
|
||||
swedishMessage EmailVerifiedChangePass = "Adress verifierad, vänligen välj nytt lösenord"
|
||||
swedishMessage EmailVerified = "Adress verifierad"
|
||||
swedishMessage InvalidKeyTitle = "Ogiltig verifikationsnyckel"
|
||||
swedishMessage InvalidKey = "Tyvärr, du angav en ogiltig verifimationsnyckel."
|
||||
swedishMessage InvalidEmailPass = "Ogiltig epost/lösenord kombination"
|
||||
@ -282,21 +269,19 @@ germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"
|
||||
germanMessage LoginOpenID = "Login via OpenID"
|
||||
germanMessage LoginGoogle = "Login via Google"
|
||||
germanMessage LoginYahoo = "Login via Yahoo"
|
||||
germanMessage Email = "E-Mail"
|
||||
germanMessage UserName = "Benutzername"
|
||||
germanMessage Email = "Email"
|
||||
germanMessage UserName = "Benutzername" -- FIXME by Google Translate "user name"
|
||||
germanMessage Password = "Passwort"
|
||||
germanMessage CurrentPassword = "Aktuelles Passwort"
|
||||
germanMessage Register = "Registrieren"
|
||||
germanMessage RegisterLong = "Neuen Account registrieren"
|
||||
germanMessage EnterEmail = "Bitte die E-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."
|
||||
germanMessage EnterEmail = "Bitte die e-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."
|
||||
germanMessage ConfirmationEmailSentTitle = "Bestätigung verschickt."
|
||||
germanMessage (ConfirmationEmailSent email) =
|
||||
"Eine Bestätigung wurde an " `mappend`
|
||||
email `mappend`
|
||||
" versandt."
|
||||
germanMessage AddressVerified = "Adresse bestätigt, bitte neues Passwort angeben"
|
||||
germanMessage EmailVerifiedChangePass = "Adresse bestätigt, bitte neues Passwort angeben"
|
||||
germanMessage EmailVerified = "Adresse bestätigt"
|
||||
germanMessage InvalidKeyTitle = "Ungültiger Bestätigungsschlüssel"
|
||||
germanMessage InvalidKey = "Das war leider ein ungültiger Bestätigungsschlüssel"
|
||||
germanMessage InvalidEmailPass = "Ungültiger Nutzername oder Passwort"
|
||||
@ -308,23 +293,24 @@ germanMessage ConfirmPass = "Bestätigen"
|
||||
germanMessage PassMismatch = "Die Passwörter stimmen nicht überein"
|
||||
germanMessage PassUpdated = "Passwort überschrieben"
|
||||
germanMessage Facebook = "Login über Facebook"
|
||||
germanMessage LoginViaEmail = "Login via E-Mail"
|
||||
germanMessage LoginViaEmail = "Login via e-Mail"
|
||||
germanMessage InvalidLogin = "Ungültiger Login"
|
||||
germanMessage NowLoggedIn = "Login erfolgreich"
|
||||
germanMessage LoginTitle = "Anmelden"
|
||||
germanMessage LoginTitle = "Log In"
|
||||
germanMessage PleaseProvideUsername = "Bitte Nutzername angeben"
|
||||
germanMessage PleaseProvidePassword = "Bitte Passwort angeben"
|
||||
germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben"
|
||||
germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter"
|
||||
germanMessage NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben"
|
||||
germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter"
|
||||
germanMessage PasswordResetTitle = "Passwort zurücksetzen"
|
||||
germanMessage ProvideIdentifier = "E-Mail-Adresse oder Nutzername"
|
||||
germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen"
|
||||
germanMessage PasswordResetPrompt = "Nach Einhabe der E-Mail-Adresse oder des Nutzernamen wird eine E-Mail zugesendet mit welcher das Passwort zurückgesetzt werden kann."
|
||||
germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"
|
||||
germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen"
|
||||
germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann."
|
||||
germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"
|
||||
germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO
|
||||
germanMessage Logout = "Abmelden"
|
||||
germanMessage LogoutTitle = "Abmelden"
|
||||
germanMessage AuthError = "Fehler beim Anmelden"
|
||||
-- TODO
|
||||
germanMessage i@(IdentifierNotFound _) = englishMessage i
|
||||
germanMessage Logout = "Ausloggen" -- FIXME by Google Translate
|
||||
germanMessage LogoutTitle = "Ausloggen" -- FIXME by Google Translate
|
||||
germanMessage AuthError = "Autorisierungsfehler" -- FIXME by Google Translate
|
||||
|
||||
frenchMessage :: AuthMessage -> Text
|
||||
frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"
|
||||
@ -344,8 +330,6 @@ frenchMessage (ConfirmationEmailSent email) =
|
||||
email `mappend`
|
||||
"."
|
||||
frenchMessage AddressVerified = "Votre adresse électronique a été validée, merci de choisir un nouveau mot de passe."
|
||||
frenchMessage EmailVerifiedChangePass = "Votre adresse électronique a été validée, merci de choisir un nouveau mot de passe."
|
||||
frenchMessage EmailVerified = "Votre adresse électronique a été validée"
|
||||
frenchMessage InvalidKeyTitle = "Clef de validation incorrecte"
|
||||
frenchMessage InvalidKey = "Désolé, mais cette clef de validation est incorrecte"
|
||||
frenchMessage InvalidEmailPass = "La combinaison de ce mot de passe et de cette adresse électronique n'existe pas."
|
||||
@ -393,8 +377,6 @@ norwegianBokmålMessage (ConfirmationEmailSent email) =
|
||||
email `mappend`
|
||||
"."
|
||||
norwegianBokmålMessage AddressVerified = "Adresse verifisert, vennligst sett et nytt passord."
|
||||
norwegianBokmålMessage EmailVerifiedChangePass = "Adresse verifisert, vennligst sett et nytt passord."
|
||||
norwegianBokmålMessage EmailVerified = "Adresse verifisert"
|
||||
norwegianBokmålMessage InvalidKeyTitle = "Ugyldig verifiseringsnøkkel"
|
||||
norwegianBokmålMessage InvalidKey = "Beklager, men det var en ugyldig verifiseringsnøkkel."
|
||||
norwegianBokmålMessage InvalidEmailPass = "Ugyldig e-post/passord-kombinasjon"
|
||||
@ -433,7 +415,7 @@ japaneseMessage LoginYahoo = "Yahooでログイン"
|
||||
japaneseMessage Email = "Eメール"
|
||||
japaneseMessage UserName = "ユーザー名" -- FIXME by Google Translate "user name"
|
||||
japaneseMessage Password = "パスワード"
|
||||
japaneseMessage CurrentPassword = "現在のパスワード"
|
||||
japaneseMessage CurrentPassword = "Current password"
|
||||
japaneseMessage Register = "登録"
|
||||
japaneseMessage RegisterLong = "新規アカウント登録"
|
||||
japaneseMessage EnterEmail = "メールアドレスを入力してください。確認メールが送られます"
|
||||
@ -443,8 +425,6 @@ japaneseMessage (ConfirmationEmailSent email) =
|
||||
email `mappend`
|
||||
" に送信しました"
|
||||
japaneseMessage AddressVerified = "アドレスは認証されました。新しいパスワードを設定してください"
|
||||
japaneseMessage EmailVerifiedChangePass = "アドレスは認証されました。新しいパスワードを設定してください"
|
||||
japaneseMessage EmailVerified = "アドレスは認証されました"
|
||||
japaneseMessage InvalidKeyTitle = "認証キーが無効です"
|
||||
japaneseMessage InvalidKey = "申し訳ありません。無効な認証キーです"
|
||||
japaneseMessage InvalidEmailPass = "メールアドレスまたはパスワードが無効です"
|
||||
@ -483,7 +463,7 @@ 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 Password = "Current password"
|
||||
finnishMessage Register = "Luo uusi"
|
||||
finnishMessage RegisterLong = "Luo uusi tili"
|
||||
finnishMessage EnterEmail = "Kirjoita alle sähköpostiosoitteesi, johon vahvistussähköposti lähetetään."
|
||||
@ -494,8 +474,6 @@ finnishMessage (ConfirmationEmailSent email) =
|
||||
"."
|
||||
|
||||
finnishMessage AddressVerified = "Sähköpostiosoite vahvistettu. Anna uusi salasana"
|
||||
finnishMessage EmailVerifiedChangePass = "Sähköpostiosoite vahvistettu. Anna uusi salasana"
|
||||
finnishMessage EmailVerified = "Sähköpostiosoite vahvistettu"
|
||||
finnishMessage InvalidKeyTitle = "Virheellinen varmistusavain"
|
||||
finnishMessage InvalidKey = "Valitettavasti varmistusavain on virheellinen."
|
||||
finnishMessage InvalidEmailPass = "Virheellinen sähköposti tai salasana."
|
||||
@ -532,9 +510,9 @@ chineseMessage LoginOpenID = "用OpenID登录"
|
||||
chineseMessage LoginGoogle = "用Google帐户登录"
|
||||
chineseMessage LoginYahoo = "用Yahoo帐户登录"
|
||||
chineseMessage Email = "邮箱"
|
||||
chineseMessage UserName = "用户名"
|
||||
chineseMessage UserName = "用户名" -- FIXME by Google Translate "user name"
|
||||
chineseMessage Password = "密码"
|
||||
chineseMessage CurrentPassword = "当前密码"
|
||||
chineseMessage CurrentPassword = "Current password"
|
||||
chineseMessage Register = "注册"
|
||||
chineseMessage RegisterLong = "注册新帐户"
|
||||
chineseMessage EnterEmail = "输入你的邮箱地址，你将收到一封确认邮件。"
|
||||
@ -544,8 +522,6 @@ chineseMessage (ConfirmationEmailSent email) =
|
||||
email `mappend`
|
||||
"."
|
||||
chineseMessage AddressVerified = "地址验证成功，请设置新密码"
|
||||
chineseMessage EmailVerifiedChangePass = "地址验证成功，请设置新密码"
|
||||
chineseMessage EmailVerified = "地址验证成功"
|
||||
chineseMessage InvalidKeyTitle = "无效的验证码"
|
||||
chineseMessage InvalidKey = "对不起，验证码无效。"
|
||||
chineseMessage InvalidEmailPass = "无效的邮箱/密码组合"
|
||||
@ -570,10 +546,11 @@ chineseMessage ProvideIdentifier = "邮箱或用户名"
|
||||
chineseMessage SendPasswordResetEmail = "发送密码重置邮件"
|
||||
chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。"
|
||||
chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"
|
||||
chineseMessage (IdentifierNotFound ident) = "邮箱/用户名不存在: " `mappend` ident
|
||||
chineseMessage Logout = "注销"
|
||||
chineseMessage LogoutTitle = "注销"
|
||||
chineseMessage AuthError = "验证错误"
|
||||
-- TODO
|
||||
chineseMessage i@(IdentifierNotFound _) = englishMessage i
|
||||
chineseMessage Logout = "註銷" -- FIXME by Google Translate
|
||||
chineseMessage LogoutTitle = "註銷" -- FIXME by Google Translate
|
||||
chineseMessage AuthError = "验证错误" -- FIXME by Google Translate
|
||||
|
||||
czechMessage :: AuthMessage -> Text
|
||||
czechMessage NoOpenID = "Nebyl nalezen identifikátor OpenID"
|
||||
@ -591,8 +568,6 @@ czechMessage ConfirmationEmailSentTitle = "Potvrzovací e-mail odeslán"
|
||||
czechMessage (ConfirmationEmailSent email) =
|
||||
"Potvrzovací e-mail byl odeslán na " `mappend` email `mappend` "."
|
||||
czechMessage AddressVerified = "Adresa byla ověřena, prosím nastavte si nové heslo"
|
||||
czechMessage EmailVerifiedChangePass = "Adresa byla ověřena, prosím nastavte si nové heslo"
|
||||
czechMessage EmailVerified = "Adresa byla ověřena"
|
||||
czechMessage InvalidKeyTitle = "Neplatný ověřovací klíč"
|
||||
czechMessage InvalidKey = "Bohužel, ověřovací klíč je neplatný."
|
||||
czechMessage InvalidEmailPass = "Neplatná kombinace e-mail/heslo"
|
||||
@ -633,7 +608,7 @@ russianMessage LoginYahoo = "Вход с помощью Yahoo"
|
||||
russianMessage Email = "Эл.почта"
|
||||
russianMessage UserName = "Имя пользователя"
|
||||
russianMessage Password = "Пароль"
|
||||
russianMessage CurrentPassword = "Старый пароль"
|
||||
russianMessage CurrentPassword = "Current password"
|
||||
russianMessage Register = "Регистрация"
|
||||
russianMessage RegisterLong = "Создать учётную запись"
|
||||
russianMessage EnterEmail = "Введите свой адрес эл.почты ниже, вам будет отправлено письмо для подтверждения."
|
||||
@ -643,8 +618,6 @@ russianMessage (ConfirmationEmailSent email) =
|
||||
email `mappend`
|
||||
"."
|
||||
russianMessage AddressVerified = "Адрес подтверждён. Пожалуйста, установите новый пароль."
|
||||
russianMessage EmailVerifiedChangePass = "Адрес подтверждён. Пожалуйста, установите новый пароль."
|
||||
russianMessage EmailVerified = "Адрес подтверждён"
|
||||
russianMessage InvalidKeyTitle = "Неверный ключ подтверждения"
|
||||
russianMessage InvalidKey = "Извините, но ключ подтверждения оказался недействительным."
|
||||
russianMessage InvalidEmailPass = "Неверное сочетание эл.почты и пароля"
|
||||
@ -692,8 +665,6 @@ dutchMessage (ConfirmationEmailSent email) =
|
||||
email `mappend`
|
||||
"."
|
||||
dutchMessage AddressVerified = "Adres geverifieerd, stel alstublieft een nieuwe wachtwoord in"
|
||||
dutchMessage EmailVerifiedChangePass = "Adres geverifieerd, stel alstublieft een nieuwe wachtwoord in"
|
||||
dutchMessage EmailVerified = "Adres geverifieerd"
|
||||
dutchMessage InvalidKeyTitle = "Ongeldig verificatietoken"
|
||||
dutchMessage InvalidKey = "Dat was helaas een ongeldig verificatietoken."
|
||||
dutchMessage InvalidEmailPass = "Ongeldige e-mailadres/wachtwoord combinatie"
|
||||
@ -741,8 +712,6 @@ croatianMessage PasswordResetPrompt = "Dolje unesite adresu e-pošte ili korisni
|
||||
croatianMessage ConfirmationEmailSentTitle = "E-poruka za potvrdu"
|
||||
croatianMessage (ConfirmationEmailSent email) = "E-poruka za potvrdu poslana je na adresu " <> email <> "."
|
||||
croatianMessage AddressVerified = "Adresa ovjerena, postavite novu lozinku"
|
||||
croatianMessage EmailVerifiedChangePass = "Adresa ovjerena, postavite novu lozinku"
|
||||
croatianMessage EmailVerified = "Adresa ovjerena"
|
||||
croatianMessage InvalidKeyTitle = "Ključ za ovjeru nije valjan"
|
||||
croatianMessage InvalidKey = "Nažalost, taj ključ za ovjeru nije valjan."
|
||||
croatianMessage InvalidEmailPass = "Kombinacija e-pošte i lozinke nije valjana"
|
||||
@ -787,8 +756,6 @@ danishMessage (ConfirmationEmailSent email) =
|
||||
email `mappend`
|
||||
"."
|
||||
danishMessage AddressVerified = "Adresse bekræftet, sæt venligst et nyt kodeord"
|
||||
danishMessage EmailVerifiedChangePass = "Adresse bekræftet, sæt venligst et nyt kodeord"
|
||||
danishMessage EmailVerified = "Adresse bekræftet"
|
||||
danishMessage InvalidKeyTitle = "Ugyldig verifikationsnøgle"
|
||||
danishMessage InvalidKey = "Beklager, det var en ugyldigt verifikationsnøgle."
|
||||
danishMessage InvalidEmailPass = "Ugyldigt e-mail/kodeord"
|
||||
@ -817,52 +784,3 @@ danishMessage (IdentifierNotFound ident) = "Brugernavn findes ikke: " `mappend`
|
||||
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 = "인증오류"
|
||||
|
||||
@ -3,7 +3,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
module Yesod.Auth.OpenId
|
||||
( authOpenId
|
||||
, forwardUrl
|
||||
@ -20,7 +19,7 @@ import Yesod.Form
|
||||
import Yesod.Core
|
||||
import Data.Text (Text, isPrefixOf)
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
import UnliftIO.Exception (tryAny)
|
||||
import Control.Exception.Lifted (SomeException, try)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
|
||||
@ -37,10 +36,7 @@ authOpenId idType extensionFields =
|
||||
AuthPlugin "openid" dispatch login
|
||||
where
|
||||
complete = PluginR "openid" ["complete"]
|
||||
|
||||
name :: Text
|
||||
name = "openid_identifier"
|
||||
|
||||
login tm = do
|
||||
ident <- newIdent
|
||||
-- FIXME this is a hack to get GHC 7.6's type checker to allow the
|
||||
@ -53,6 +49,9 @@ authOpenId idType extensionFields =
|
||||
|] $ x `asTypeOf` y)
|
||||
[whamlet|
|
||||
$newline never
|
||||
<form method="get" action="@{tm forwardUrl}">
|
||||
<input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id">
|
||||
<button .openid-google>_{Msg.LoginGoogle}
|
||||
<form method="get" action="@{tm forwardUrl}">
|
||||
<input type="hidden" name="openid_identifier" value="http://me.yahoo.com">
|
||||
<button .openid-yahoo>_{Msg.LoginYahoo}
|
||||
@ -61,19 +60,19 @@ $newline never
|
||||
<input id="#{ident}" type="text" name="#{name}" value="http://">
|
||||
<input type="submit" value="_{Msg.LoginOpenID}">
|
||||
|]
|
||||
|
||||
dispatch :: Text -> [Text] -> AuthHandler master TypedContent
|
||||
dispatch "GET" ["forward"] = do
|
||||
roid <- runInputGet $ iopt textField name
|
||||
roid <- lift $ runInputGet $ iopt textField name
|
||||
case roid of
|
||||
Just oid -> do
|
||||
tm <- getRouteToParent
|
||||
render <- getUrlRender
|
||||
let complete' = render $ tm complete
|
||||
manager <- authHttpManager
|
||||
eres <- tryAny $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager
|
||||
let complete' = render complete
|
||||
master <- lift 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
|
||||
tm <- getRouteToParent
|
||||
lift $ loginErrorMessage (tm LoginR) $ T.pack $
|
||||
show (err :: SomeException)
|
||||
Right x -> redirect x
|
||||
Nothing -> loginErrorMessageI LoginR Msg.NoOpenID
|
||||
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
|
||||
@ -88,13 +87,14 @@ $newline never
|
||||
|
||||
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
|
||||
completeHelper idType gets' = do
|
||||
manager <- authHttpManager
|
||||
eres <- tryAny $ OpenId.authenticateClaimed gets' manager
|
||||
master <- lift getYesod
|
||||
eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
|
||||
either onFailure onSuccess eres
|
||||
where
|
||||
onFailure err = do
|
||||
tm <- getRouteToParent
|
||||
loginErrorMessage (tm LoginR) $ T.pack $ show err
|
||||
lift $ loginErrorMessage (tm LoginR) $ T.pack $
|
||||
show (err :: SomeException)
|
||||
onSuccess oir = do
|
||||
let claimed =
|
||||
case OpenId.oirClaimed oir of
|
||||
@ -108,7 +108,7 @@ completeHelper idType gets' = do
|
||||
case idType of
|
||||
OPLocal -> OpenId.oirOpLocal oir
|
||||
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
|
||||
setCredsRedirect $ Creds "openid" i gets''
|
||||
lift $ setCredsRedirect $ Creds "openid" i gets''
|
||||
|
||||
-- | The main identifier provided by the OpenID authentication plugin is the
|
||||
-- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Yesod.Auth.Routes where
|
||||
|
||||
|
||||
@ -2,7 +2,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
module Yesod.Auth.Rpxnow
|
||||
( authRpxnow
|
||||
) where
|
||||
@ -18,10 +17,10 @@ import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Control.Arrow ((***))
|
||||
import Network.HTTP.Types (renderQuery)
|
||||
|
||||
authRpxnow :: YesodAuth master
|
||||
authRpxnow :: YesodAuth m
|
||||
=> String -- ^ app name
|
||||
-> String -- ^ key
|
||||
-> AuthPlugin master
|
||||
-> AuthPlugin m
|
||||
authRpxnow app apiKey =
|
||||
AuthPlugin "rpxnow" dispatch login
|
||||
where
|
||||
@ -33,16 +32,14 @@ authRpxnow app apiKey =
|
||||
$newline never
|
||||
<iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
|
||||
|]
|
||||
|
||||
dispatch :: a -> [b] -> AuthHandler master TypedContent
|
||||
dispatch _ [] = do
|
||||
token1 <- lookupGetParams "token"
|
||||
token2 <- lookupPostParams "token"
|
||||
token <- case token1 ++ token2 of
|
||||
[] -> invalidArgs ["token: Value not supplied"]
|
||||
x:_ -> return $ unpack x
|
||||
manager <- authHttpManager
|
||||
Rpxnow.Identifier ident extra <- Rpxnow.authenticate apiKey token manager
|
||||
master <- lift getYesod
|
||||
Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master)
|
||||
let creds =
|
||||
Creds "rpxnow" ident
|
||||
$ maybe id (\x -> (:) ("verifiedEmail", x))
|
||||
@ -50,7 +47,7 @@ $newline never
|
||||
$ maybe id (\x -> (:) ("displayName", x))
|
||||
(fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
|
||||
[]
|
||||
setCredsRedirect creds
|
||||
lift $ setCredsRedirect creds
|
||||
dispatch _ _ = notFound
|
||||
|
||||
-- | Get some form of a display name.
|
||||
|
||||
@ -1,8 +1,13 @@
|
||||
{-# 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.
|
||||
-- Module : Crypto.PasswordStore
|
||||
-- Copyright : (c) Peter Scott, 2011
|
||||
-- License : BSD-style
|
||||
--
|
||||
-- Maintainer : pjscott@iastate.edu
|
||||
-- Stability : experimental
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Securely store hashed, salted passwords. If you need to store and verify
|
||||
-- passwords, there are many wrong ways to do it, most of them all too
|
||||
@ -65,10 +70,8 @@
|
||||
-- Note that, as of version 2.4, you can also use PBKDF2, and specify the exact
|
||||
-- iteration count. This does not have a significant effect on security, but can
|
||||
-- be handy for compatibility with other code.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
|
||||
module Yesod.Auth.Util.PasswordStore (
|
||||
module Yesod.PasswordStore (
|
||||
|
||||
-- * Algorithms
|
||||
pbkdf1, -- :: ByteString -> Salt -> Int -> ByteString
|
||||
@ -99,14 +102,16 @@ module Yesod.Auth.Util.PasswordStore (
|
||||
importSalt -- :: ByteString -> Salt
|
||||
) where
|
||||
|
||||
import qualified Crypto.MAC.HMAC as CH
|
||||
|
||||
import qualified Crypto.Hash as CH
|
||||
import qualified Crypto.Hash.SHA256 as H
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Binary as Binary
|
||||
import Control.Monad
|
||||
import Control.Monad.ST
|
||||
import Data.Byteable (toBytes)
|
||||
import Data.STRef
|
||||
import Data.Bits
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
@ -115,7 +120,6 @@ import System.IO
|
||||
import System.Random
|
||||
import Data.Maybe
|
||||
import qualified Control.Exception
|
||||
import Data.ByteArray (convert)
|
||||
|
||||
---------------------
|
||||
-- Cryptographic base
|
||||
@ -128,23 +132,16 @@ import Data.ByteArray (convert)
|
||||
-- key should be stored in the password file. When a user wishes to authenticate
|
||||
-- a password, just pass it and the salt to this function, and see if the output
|
||||
-- matches.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
pbkdf1 :: ByteString -> Salt -> Int -> ByteString
|
||||
pbkdf1 password (SaltBS salt) iter = hashRounds first_hash (iter + 1)
|
||||
where
|
||||
first_hash =
|
||||
convert $
|
||||
((CH.hashFinalize $ CH.hashInit `CH.hashUpdate` password `CH.hashUpdate` salt) :: CH.Digest CH.SHA256)
|
||||
|
||||
where first_hash = H.finalize $ H.init `H.update` password `H.update` salt
|
||||
|
||||
-- | Hash a 'ByteString' for a given number of rounds. The number of rounds is 0
|
||||
-- or more. If the number of rounds specified is 0, the ByteString will be
|
||||
-- returned unmodified.
|
||||
hashRounds :: ByteString -> Int -> ByteString
|
||||
hashRounds (!bs) 0 = bs
|
||||
hashRounds bs rounds = hashRounds (convert (CH.hash bs :: CH.Digest CH.SHA256)) (rounds - 1)
|
||||
hashRounds bs rounds = hashRounds (H.hash bs) (rounds - 1)
|
||||
|
||||
-- | Computes the hmacSHA256 of the given message, with the given 'Salt'.
|
||||
hmacSHA256 :: ByteString
|
||||
@ -154,22 +151,19 @@ hmacSHA256 :: ByteString
|
||||
-> ByteString
|
||||
-- ^ The encoded message
|
||||
hmacSHA256 secret msg =
|
||||
convert (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)
|
||||
toBytes (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)
|
||||
|
||||
-- | PBKDF2 key-derivation function.
|
||||
-- For details see @http://tools.ietf.org/html/rfc2898@.
|
||||
-- @32@ is the most common digest size for @SHA256@, and is
|
||||
-- what the algorithm internally uses.
|
||||
-- @HMAC+SHA256@ is used as @PRF@, because @HMAC+SHA1@ is considered too weak.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
pbkdf2 :: ByteString -> Salt -> Int -> ByteString
|
||||
pbkdf2 password (SaltBS salt) c =
|
||||
let hLen = 32
|
||||
dkLen = hLen in go hLen dkLen
|
||||
where
|
||||
go hLen dkLen | dkLen > (2^(32 :: Int) - 1) * hLen = error "Derived key too long."
|
||||
go hLen dkLen | dkLen > (2^32 - 1) * hLen = error "Derived key too long."
|
||||
| otherwise =
|
||||
let !l = ceiling ((fromIntegral dkLen / fromIntegral hLen) :: Double)
|
||||
!r = dkLen - (l - 1) * hLen
|
||||
@ -202,9 +196,6 @@ pbkdf2 password (SaltBS salt) c =
|
||||
-- | Generate a 'Salt' from 128 bits of data from @\/dev\/urandom@, with the
|
||||
-- system RNG as a fallback. This is the function used to generate salts by
|
||||
-- 'makePassword'.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
genSaltIO :: IO Salt
|
||||
genSaltIO =
|
||||
Control.Exception.catch genSaltDevURandom def
|
||||
@ -258,9 +249,6 @@ writePwHash (strength, SaltBS salt, hash) =
|
||||
-- database. Generates a salt using high-quality randomness from
|
||||
-- @\/dev\/urandom@ or (if that is not available, for example on Windows)
|
||||
-- 'System.Random', which is included in the hashed output.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
makePassword :: ByteString -> Int -> IO ByteString
|
||||
makePassword = makePasswordWith pbkdf1
|
||||
|
||||
@ -269,8 +257,6 @@ makePassword = makePasswordWith pbkdf1
|
||||
--
|
||||
-- >>> makePasswordWith pbkdf1 "password" 14
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
makePasswordWith :: (ByteString -> Salt -> Int -> ByteString)
|
||||
-- ^ The algorithm to use (e.g. pbkdf1)
|
||||
-> ByteString
|
||||
@ -287,9 +273,6 @@ makePasswordWith algorithm password strength = do
|
||||
-- Note that, unlike 'makePasswordWith', this function takes the @raw@
|
||||
-- number of iterations. This means the user will need to specify a
|
||||
-- sensible value, typically @10000@ or @20000@.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
makePasswordSaltWith :: (ByteString -> Salt -> Int -> ByteString)
|
||||
-- ^ A function modeling an algorithm (e.g. 'pbkdf1')
|
||||
-> (Int -> Int)
|
||||
@ -310,9 +293,6 @@ makePasswordSaltWith algorithm strengthModifier pwd salt strength = writePwHash
|
||||
--
|
||||
-- > >>> makePasswordSalt "hunter2" (makeSalt "72cd18b5ebfe6e96") 14
|
||||
-- > "sha256|14|NzJjZDE4YjVlYmZlNmU5Ng==|yuiNrZW3KHX+pd0sWy9NTTsy5Yopmtx4UYscItSsoxc="
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
makePasswordSalt :: ByteString -> Salt -> Int -> ByteString
|
||||
makePasswordSalt = makePasswordSaltWith pbkdf1 (2^)
|
||||
|
||||
@ -329,8 +309,6 @@ makePasswordSalt = makePasswordSaltWith pbkdf1 (2^)
|
||||
-- > >>> verifyPasswordWith pbkdf2 id "hunter2" "sha256..."
|
||||
-- > True
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
verifyPasswordWith :: (ByteString -> Salt -> Int -> ByteString)
|
||||
-- ^ A function modeling an algorithm (e.g. pbkdf1)
|
||||
-> (Int -> Int)
|
||||
@ -347,9 +325,6 @@ verifyPasswordWith algorithm strengthModifier userInput pwHash =
|
||||
encode (algorithm userInput salt (strengthModifier strength)) == goodHash
|
||||
|
||||
-- | Like 'verifyPasswordWith', but uses 'pbkdf1' as algorithm.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
verifyPassword :: ByteString -> ByteString -> Bool
|
||||
verifyPassword = verifyPasswordWith pbkdf1 (2^)
|
||||
|
||||
@ -363,9 +338,6 @@ verifyPassword = verifyPasswordWith pbkdf1 (2^)
|
||||
-- This function can be used to periodically update your password database when
|
||||
-- computers get faster, in order to keep up with Moore's law. This isn't hugely
|
||||
-- important, but it's a good idea.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
strengthenPassword :: ByteString -> Int -> ByteString
|
||||
strengthenPassword pwHash newstr =
|
||||
case readPwHash pwHash of
|
||||
@ -380,9 +352,6 @@ strengthenPassword pwHash newstr =
|
||||
hash = decodeLenient hashB64
|
||||
|
||||
-- | Return the strength of a password hash.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
passwordStrength :: ByteString -> Int
|
||||
passwordStrength pwHash = case readPwHash pwHash of
|
||||
Nothing -> 0
|
||||
@ -396,18 +365,12 @@ passwordStrength pwHash = case readPwHash pwHash of
|
||||
-- hash. You can generate a salt with 'genSaltIO' or 'genSaltRandom', or if you
|
||||
-- really know what you're doing, you can create them from your own ByteString
|
||||
-- values with 'makeSalt'.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
newtype Salt = SaltBS ByteString
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | Create a 'Salt' from a 'ByteString'. The input must be at least 8
|
||||
-- characters, and can contain arbitrary bytes. Most users will not need to use
|
||||
-- this function.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
makeSalt :: ByteString -> Salt
|
||||
makeSalt = SaltBS . encode . check_length
|
||||
where check_length salt | B.length salt < 8 =
|
||||
@ -416,26 +379,17 @@ makeSalt = SaltBS . encode . check_length
|
||||
|
||||
-- | Convert a 'Salt' into a 'ByteString'. The resulting 'ByteString' will be
|
||||
-- base64-encoded. Most users will not need to use this function.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
exportSalt :: Salt -> ByteString
|
||||
exportSalt (SaltBS bs) = bs
|
||||
|
||||
-- | Convert a raw 'ByteString' into a 'Salt'.
|
||||
-- Use this function with caution, since using a weak salt will result in a
|
||||
-- weak password.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
importSalt :: ByteString -> Salt
|
||||
importSalt = SaltBS
|
||||
|
||||
-- | Is the format of a password hash valid? Attempts to parse a given password
|
||||
-- hash. Returns 'True' if it parses correctly, and 'False' otherwise.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
isPasswordFormatValid :: ByteString -> Bool
|
||||
isPasswordFormatValid = isJust . readPwHash
|
||||
|
||||
@ -443,9 +397,6 @@ isPasswordFormatValid = isJust . readPwHash
|
||||
-- generator. Returns the salt and the updated random number generator. This is
|
||||
-- meant to be used with 'makePasswordSalt' by people who would prefer to either
|
||||
-- use their own random number generator or avoid the 'IO' monad.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
genSaltRandom :: (RandomGen b) => b -> (Salt, b)
|
||||
genSaltRandom gen = (salt, newgen)
|
||||
where rands _ 0 = []
|
||||
@ -462,3 +413,17 @@ modifySTRef' ref f = do
|
||||
let x' = f x
|
||||
x' `seq` writeSTRef ref x'
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_bytestring(0, 10, 0)
|
||||
toStrict :: BL.ByteString -> BS.ByteString
|
||||
toStrict = BL.toStrict
|
||||
|
||||
fromStrict :: BS.ByteString -> BL.ByteString
|
||||
fromStrict = BL.fromStrict
|
||||
#else
|
||||
toStrict :: BL.ByteString -> BS.ByteString
|
||||
toStrict = BS.concat . BL.toChunks
|
||||
|
||||
fromStrict :: BS.ByteString -> BL.ByteString
|
||||
fromStrict = BL.fromChunks . return
|
||||
#endif
|
||||
@ -1,6 +1,5 @@
|
||||
cabal-version: >=1.10
|
||||
name: yesod-auth
|
||||
version: 1.6.11.2
|
||||
version: 1.4.13.5
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman, Patrick Brisbin
|
||||
@ -8,6 +7,7 @@ maintainer: Michael Snoyman <michael@snoyman.com>
|
||||
synopsis: Authentication for Yesod.
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.6.0
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-auth>
|
||||
@ -20,49 +20,51 @@ flag network-uri
|
||||
default: True
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
build-depends: base >= 4.10 && < 5
|
||||
, aeson >= 0.7
|
||||
, attoparsec-aeson >= 2.1
|
||||
, authenticate >= 1.3.4
|
||||
build-depends: base >= 4 && < 5
|
||||
, authenticate >= 1.3
|
||||
, bytestring >= 0.9.1.4
|
||||
, yesod-core >= 1.4.20 && < 1.5
|
||||
, wai >= 1.4
|
||||
, template-haskell
|
||||
, base16-bytestring
|
||||
, base64-bytestring
|
||||
, binary
|
||||
, blaze-builder
|
||||
, cryptohash
|
||||
, random >= 1.0.0.2
|
||||
, text >= 0.7
|
||||
, mime-mail >= 0.3
|
||||
, yesod-persistent >= 1.4
|
||||
, shakespeare
|
||||
, containers
|
||||
, unordered-containers
|
||||
, yesod-form >= 1.4 && < 1.5
|
||||
, transformers >= 0.2.2
|
||||
, persistent >= 2.1 && < 2.7
|
||||
, persistent-template >= 2.1 && < 2.7
|
||||
, http-client
|
||||
, http-conduit >= 2.1
|
||||
, aeson >= 0.7
|
||||
, lifted-base >= 0.1
|
||||
, blaze-html >= 0.5
|
||||
, blaze-markup >= 0.5.1
|
||||
, bytestring >= 0.9.1.4
|
||||
, conduit >= 1.3
|
||||
, conduit-extra
|
||||
, containers
|
||||
, cryptonite
|
||||
, data-default
|
||||
, email-validate >= 1.0
|
||||
, file-embed
|
||||
, http-client >= 0.5
|
||||
, http-client-tls
|
||||
, http-conduit >= 2.1
|
||||
, http-types
|
||||
, memory
|
||||
, nonce >= 1.0.2 && < 1.1
|
||||
, persistent >= 2.8
|
||||
, random >= 1.0.0.2
|
||||
, file-embed
|
||||
, email-validate >= 1.0
|
||||
, data-default
|
||||
, resourcet
|
||||
, safe
|
||||
, shakespeare
|
||||
, template-haskell
|
||||
, text >= 0.7
|
||||
, time
|
||||
, transformers >= 0.2.2
|
||||
, unliftio
|
||||
, unliftio-core
|
||||
, unordered-containers
|
||||
, wai >= 1.4
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, yesod-form >= 1.6 && < 1.8
|
||||
, yesod-persistent >= 1.6
|
||||
, base64-bytestring
|
||||
, byteable
|
||||
, binary
|
||||
, http-client
|
||||
, blaze-builder
|
||||
, conduit
|
||||
, conduit-extra
|
||||
, nonce >= 1.0.2 && < 1.1
|
||||
|
||||
if flag(network-uri)
|
||||
build-depends: network-uri >= 2.6
|
||||
else
|
||||
build-depends: network < 2.6
|
||||
|
||||
exposed-modules: Yesod.Auth
|
||||
Yesod.Auth.BrowserId
|
||||
@ -71,10 +73,11 @@ library
|
||||
Yesod.Auth.OpenId
|
||||
Yesod.Auth.Rpxnow
|
||||
Yesod.Auth.Message
|
||||
Yesod.Auth.GoogleEmail
|
||||
Yesod.Auth.GoogleEmail2
|
||||
Yesod.Auth.Hardcoded
|
||||
Yesod.Auth.Util.PasswordStore
|
||||
other-modules: Yesod.Auth.Routes
|
||||
Yesod.PasswordStore
|
||||
ghc-options: -Wall
|
||||
|
||||
source-repository head
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
module AddHandler (addHandler) where
|
||||
|
||||
@ -6,24 +5,9 @@ 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 Data.Maybe (fromMaybe)
|
||||
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)
|
||||
|
||||
@ -47,7 +31,7 @@ cmdLineArgsError = "You have to specify a route name if you want to add handler
|
||||
addHandler :: Maybe String -> Maybe String -> [String] -> IO ()
|
||||
addHandler (Just route) pat met = do
|
||||
cabal <- getCabal
|
||||
checked <- checkRoute route cabal
|
||||
checked <- checkRoute route
|
||||
let routePair = case checked of
|
||||
Left err@EmptyRoute -> (error . show) err
|
||||
Left err@RouteCaseError -> (error . show) err
|
||||
@ -67,18 +51,18 @@ addHandlerInteractive :: IO ()
|
||||
addHandlerInteractive = do
|
||||
cabal <- getCabal
|
||||
let routeInput = do
|
||||
putStr "Name of route (without trailing R): "
|
||||
hFlush stdout
|
||||
name <- getLine
|
||||
checked <- checkRoute name cabal
|
||||
case checked of
|
||||
Left err@EmptyRoute -> (error . show) err
|
||||
Left err@RouteCaseError -> print err >> routeInput
|
||||
Left err@(RouteExists _) -> do
|
||||
print err
|
||||
putStrLn "Try another name or leave blank to exit"
|
||||
routeInput
|
||||
Right p -> return p
|
||||
putStr "Name of route (without trailing R): "
|
||||
hFlush stdout
|
||||
name <- getLine
|
||||
checked <- checkRoute name
|
||||
case checked of
|
||||
Left err@EmptyRoute -> (error . show) err
|
||||
Left err@RouteCaseError -> print err >> routeInput
|
||||
Left err@(RouteExists _) -> do
|
||||
print err
|
||||
putStrLn "Try another name or leave blank to exit"
|
||||
routeInput
|
||||
Right p -> return p
|
||||
|
||||
routePair <- routeInput
|
||||
putStr "Enter route pattern (ex: /entry/#EntryId): "
|
||||
@ -89,22 +73,11 @@ addHandlerInteractive = do
|
||||
methods <- getLine
|
||||
addHandlerFiles cabal routePair pattern methods
|
||||
|
||||
getRoutesFilePath :: IO FilePath
|
||||
getRoutesFilePath = do
|
||||
let oldPath = "config/routes"
|
||||
oldExists <- doesFileExist oldPath
|
||||
pure $ if oldExists
|
||||
then oldPath
|
||||
else "config/routes.yesodroutes"
|
||||
|
||||
addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO ()
|
||||
addHandlerFiles cabal (name, handlerFile) pattern methods = do
|
||||
src <- getSrcDir cabal
|
||||
let applicationFile = concat [src, "/Application.hs"]
|
||||
modify applicationFile $ fixApp name
|
||||
modify "Application.hs" $ fixApp name
|
||||
modify cabal $ fixCabal name
|
||||
routesPath <- getRoutesFilePath
|
||||
modify routesPath $ fixRoutes name pattern methods
|
||||
modify "config/routes" $ fixRoutes name pattern methods
|
||||
writeFile handlerFile $ mkHandler name pattern methods
|
||||
specExists <- doesFileExist specFile
|
||||
unless specExists $
|
||||
@ -121,16 +94,15 @@ getCabal = do
|
||||
[] -> error "No cabal file found"
|
||||
_ -> error "Too many cabal files found"
|
||||
|
||||
checkRoute :: String -> FilePath -> IO (Either RouteError (String, FilePath))
|
||||
checkRoute name cabal =
|
||||
checkRoute :: String -> IO (Either RouteError (String, FilePath))
|
||||
checkRoute name =
|
||||
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"]
|
||||
let handlerFile = concat ["Handler/", name, ".hs"]
|
||||
exists <- doesFileExist handlerFile
|
||||
if exists
|
||||
then (return . Left . RouteExists) handlerFile
|
||||
@ -242,18 +214,3 @@ mkHandler name pattern methods = unlines
|
||||
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
|
||||
|
||||
270
yesod-bin/Build.hs
Normal file
270
yesod-bin/Build.hs
Normal file
@ -0,0 +1,270 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Build
|
||||
( getDeps
|
||||
, touchDeps
|
||||
, touch
|
||||
, recompDeps
|
||||
, isNewerThan
|
||||
, safeReadFile
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<|>), many, (<$>))
|
||||
import qualified Data.Attoparsec.Text as A
|
||||
import Data.Char (isSpace, isUpper)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as S
|
||||
|
||||
import Control.Exception (SomeException, try, IOException)
|
||||
import Control.Exception.Lifted (handle)
|
||||
import Control.Monad (when, filterM, forM, forM_, (>=>))
|
||||
import Control.Monad.Trans.State (StateT, get, put, execStateT)
|
||||
import Control.Monad.Trans.Writer (WriterT, tell, execWriterT)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
|
||||
import Data.Monoid (Monoid (mappend, mempty))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified System.Posix.Types
|
||||
import System.Directory
|
||||
import System.FilePath (takeExtension, replaceExtension, (</>), takeDirectory,
|
||||
splitPath, joinPath)
|
||||
import System.PosixCompat.Files (getFileStatus, setFileTimes,
|
||||
accessTime, modificationTime)
|
||||
|
||||
import Text.Shakespeare (Deref)
|
||||
import Text.Julius (juliusUsedIdentifiers)
|
||||
import Text.Cassius (cassiusUsedIdentifiers)
|
||||
import Text.Lucius (luciusUsedIdentifiers)
|
||||
|
||||
safeReadFile :: MonadIO m => FilePath -> m (Either IOException ByteString)
|
||||
safeReadFile = liftIO . try . S.readFile
|
||||
|
||||
touch :: IO ()
|
||||
touch = do
|
||||
m <- handle (\(_ :: SomeException) -> return Map.empty) $ readFile touchCache >>= readIO
|
||||
x <- fmap snd (getDeps [])
|
||||
m' <- execStateT (execWriterT $ touchDeps id updateFileTime x) m
|
||||
createDirectoryIfMissing True $ takeDirectory touchCache
|
||||
writeFile touchCache $ show m'
|
||||
where
|
||||
touchCache = "dist/touchCache.txt"
|
||||
|
||||
-- | Returns True if any files were touched, otherwise False
|
||||
recompDeps :: [FilePath] -> StateT (Map.Map FilePath (Set.Set Deref)) IO Bool
|
||||
recompDeps =
|
||||
fmap toBool . execWriterT . (liftIO . getDeps >=> touchDeps hiFile removeHi . snd)
|
||||
where
|
||||
toBool NoFilesTouched = False
|
||||
toBool SomeFilesTouched = True
|
||||
|
||||
type Deps = Map.Map FilePath ([FilePath], ComparisonType)
|
||||
|
||||
getDeps :: [FilePath] -> IO ([FilePath], Deps)
|
||||
getDeps hsSourceDirs = do
|
||||
let defSrcDirs = case hsSourceDirs of
|
||||
[] -> ["."]
|
||||
ds -> ds
|
||||
hss <- fmap concat $ mapM findHaskellFiles defSrcDirs
|
||||
deps' <- mapM determineDeps hss
|
||||
return $ (hss, fixDeps $ zip hss deps')
|
||||
|
||||
data AnyFilesTouched = NoFilesTouched | SomeFilesTouched
|
||||
instance Monoid AnyFilesTouched where
|
||||
mempty = NoFilesTouched
|
||||
mappend NoFilesTouched NoFilesTouched = mempty
|
||||
mappend _ _ = SomeFilesTouched
|
||||
|
||||
touchDeps :: (FilePath -> FilePath) ->
|
||||
(FilePath -> FilePath -> IO ()) ->
|
||||
Deps -> WriterT AnyFilesTouched (StateT (Map.Map FilePath (Set.Set Deref)) IO) ()
|
||||
touchDeps f action deps = (mapM_ go . Map.toList) deps
|
||||
where
|
||||
go (x, (ys, ct)) = do
|
||||
isChanged <- handle (\(_ :: SomeException) -> return True) $ lift $
|
||||
case ct of
|
||||
AlwaysOutdated -> return True
|
||||
CompareUsedIdentifiers getDerefs -> do
|
||||
derefMap <- get
|
||||
ebs <- safeReadFile x
|
||||
let newDerefs =
|
||||
case ebs of
|
||||
Left _ -> Set.empty
|
||||
Right bs -> Set.fromList $ getDerefs $ T.unpack $ decodeUtf8With lenientDecode bs
|
||||
put $ Map.insert x newDerefs derefMap
|
||||
case Map.lookup x derefMap of
|
||||
Just oldDerefs | oldDerefs == newDerefs -> return False
|
||||
_ -> return True
|
||||
when isChanged $ forM_ ys $ \y -> do
|
||||
n <- liftIO $ x `isNewerThan` f y
|
||||
when n $ do
|
||||
liftIO $ putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x)
|
||||
liftIO $ action x y
|
||||
tell SomeFilesTouched
|
||||
|
||||
-- | remove the .hi files for a .hs file, thereby forcing a recompile
|
||||
removeHi :: FilePath -> FilePath -> IO ()
|
||||
removeHi _ hs = mapM_ removeFile' hiFiles
|
||||
where
|
||||
removeFile' file = try' (removeFile file) >> return ()
|
||||
hiFiles = map (\e -> "dist/build" </> removeSrc (replaceExtension hs e))
|
||||
["hi", "p_hi"]
|
||||
|
||||
-- | change file mtime of .hs file to that of the dependency
|
||||
updateFileTime :: FilePath -> FilePath -> IO ()
|
||||
updateFileTime x hs = do
|
||||
(_ , modx) <- getFileStatus' x
|
||||
(access, _ ) <- getFileStatus' hs
|
||||
_ <- try' (setFileTimes hs access modx)
|
||||
return ()
|
||||
|
||||
hiFile :: FilePath -> FilePath
|
||||
hiFile hs = "dist/build" </> removeSrc (replaceExtension hs "hi")
|
||||
|
||||
removeSrc :: FilePath -> FilePath
|
||||
removeSrc f = case splitPath f of
|
||||
("src/" : xs) -> joinPath xs
|
||||
_ -> f
|
||||
|
||||
try' :: IO x -> IO (Either SomeException x)
|
||||
try' = try
|
||||
|
||||
isNewerThan :: FilePath -> FilePath -> IO Bool
|
||||
isNewerThan f1 f2 = do
|
||||
(_, mod1) <- getFileStatus' f1
|
||||
(_, mod2) <- getFileStatus' f2
|
||||
return (mod1 > mod2)
|
||||
|
||||
getFileStatus' :: FilePath ->
|
||||
IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime)
|
||||
getFileStatus' fp = do
|
||||
efs <- try' $ getFileStatus fp
|
||||
case efs of
|
||||
Left _ -> return (0, 0)
|
||||
Right fs -> return (accessTime fs, modificationTime fs)
|
||||
|
||||
fixDeps :: [(FilePath, [(ComparisonType, FilePath)])] -> Deps
|
||||
fixDeps =
|
||||
Map.unionsWith combine . map go
|
||||
where
|
||||
go :: (FilePath, [(ComparisonType, FilePath)]) -> Deps
|
||||
go (x, ys) = Map.fromList $ map (\(ct, y) -> (y, ([x], ct))) ys
|
||||
|
||||
combine (ys1, ct) (ys2, _) = (ys1 `mappend` ys2, ct)
|
||||
|
||||
findHaskellFiles :: FilePath -> IO [FilePath]
|
||||
findHaskellFiles path = do
|
||||
contents <- getDirectoryContents path
|
||||
fmap concat $ mapM go contents
|
||||
where
|
||||
go ('.':_) = return []
|
||||
go filename = do
|
||||
d <- doesDirectoryExist full
|
||||
if not d
|
||||
then if isHaskellFile
|
||||
then return [full]
|
||||
else return []
|
||||
else if isHaskellDir
|
||||
then findHaskellFiles full
|
||||
else return []
|
||||
where
|
||||
-- this could fail on unicode
|
||||
isHaskellDir = isUpper (head filename)
|
||||
isHaskellFile = takeExtension filename `elem` watch_files
|
||||
full = path </> filename
|
||||
watch_files = [".hs", ".lhs"]
|
||||
|
||||
data TempType = StaticFiles FilePath
|
||||
| Verbatim | Messages FilePath | Hamlet | Widget | Julius | Cassius | Lucius
|
||||
deriving Show
|
||||
|
||||
-- | How to tell if a file is outdated.
|
||||
data ComparisonType = AlwaysOutdated
|
||||
| CompareUsedIdentifiers (String -> [Deref])
|
||||
|
||||
determineDeps :: FilePath -> IO [(ComparisonType, FilePath)]
|
||||
determineDeps x = do
|
||||
y <- safeReadFile x
|
||||
case y of
|
||||
Left _ -> return []
|
||||
Right bs -> do
|
||||
let z = A.parseOnly (many $ (parser <|> (A.anyChar >> return Nothing)))
|
||||
$ decodeUtf8With lenientDecode bs
|
||||
case z of
|
||||
Left _ -> return []
|
||||
Right r -> mapM go r >>= filterM (doesFileExist . snd) . concat
|
||||
where
|
||||
go (Just (StaticFiles fp, _)) = map ((,) AlwaysOutdated) <$> getFolderContents fp
|
||||
go (Just (Hamlet, f)) = return [(AlwaysOutdated, f)]
|
||||
go (Just (Widget, f)) = return
|
||||
[ (AlwaysOutdated, "templates/" ++ f ++ ".hamlet")
|
||||
, (CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, "templates/" ++ f ++ ".julius")
|
||||
, (CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, "templates/" ++ f ++ ".lucius")
|
||||
, (CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, "templates/" ++ f ++ ".cassius")
|
||||
]
|
||||
go (Just (Julius, f)) = return [(CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, f)]
|
||||
go (Just (Cassius, f)) = return [(CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, f)]
|
||||
go (Just (Lucius, f)) = return [(CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, f)]
|
||||
go (Just (Verbatim, f)) = return [(AlwaysOutdated, f)]
|
||||
go (Just (Messages f, _)) = map ((,) AlwaysOutdated) <$> getFolderContents f
|
||||
go Nothing = return []
|
||||
|
||||
parser = do
|
||||
ty <- (do _ <- A.string "\nstaticFiles \""
|
||||
x' <- A.many1 $ A.satisfy (/= '"')
|
||||
return $ StaticFiles x')
|
||||
<|> (A.string "$(parseRoutesFile " >> return Verbatim)
|
||||
<|> (A.string "$(hamletFile " >> return Hamlet)
|
||||
<|> (A.string "$(ihamletFile " >> return Hamlet)
|
||||
<|> (A.string "$(whamletFile " >> return Hamlet)
|
||||
<|> (A.string "$(html " >> return Hamlet)
|
||||
<|> (A.string "$(widgetFile " >> return Widget)
|
||||
<|> (A.string "$(Settings.hamletFile " >> return Hamlet)
|
||||
<|> (A.string "$(Settings.widgetFile " >> return Widget)
|
||||
<|> (A.string "$(juliusFile " >> return Julius)
|
||||
<|> (A.string "$(cassiusFile " >> return Cassius)
|
||||
<|> (A.string "$(luciusFile " >> return Lucius)
|
||||
<|> (A.string "$(persistFile " >> return Verbatim)
|
||||
<|> (
|
||||
A.string "$(persistFileWith " >>
|
||||
A.many1 (A.satisfy (/= '"')) >>
|
||||
return Verbatim)
|
||||
<|> (do
|
||||
_ <- A.string "\nmkMessage \""
|
||||
A.skipWhile (/= '"')
|
||||
_ <- A.string "\" \""
|
||||
x' <- A.many1 $ A.satisfy (/= '"')
|
||||
_ <- A.string "\" \""
|
||||
_y <- A.many1 $ A.satisfy (/= '"')
|
||||
_ <- A.string "\""
|
||||
return $ Messages x')
|
||||
case ty of
|
||||
Messages{} -> return $ Just (ty, "")
|
||||
StaticFiles{} -> return $ Just (ty, "")
|
||||
_ -> do
|
||||
A.skipWhile isSpace
|
||||
_ <- A.char '"'
|
||||
y <- A.many1 $ A.satisfy (/= '"')
|
||||
_ <- A.char '"'
|
||||
A.skipWhile isSpace
|
||||
_ <- A.char ')'
|
||||
return $ Just (ty, y)
|
||||
|
||||
getFolderContents :: FilePath -> IO [FilePath]
|
||||
getFolderContents fp = do
|
||||
cs <- getDirectoryContents fp
|
||||
let notHidden ('.':_) = False
|
||||
notHidden ('t':"mp") = False
|
||||
notHidden ('f':"ay") = False
|
||||
notHidden _ = True
|
||||
fmap concat $ forM (filter notHidden cs) $ \c -> do
|
||||
let f = fp ++ '/' : c
|
||||
isFile <- doesFileExist f
|
||||
if isFile then return [f] else getFolderContents f
|
||||
@ -1,108 +1,3 @@
|
||||
# ChangeLog for yesod-bin
|
||||
|
||||
## 1.6.2.2
|
||||
|
||||
* Support Cabal 3.8 [#1769](https://github.com/yesodweb/yesod/pull/1769)
|
||||
|
||||
## 1.6.2.1
|
||||
|
||||
* Support Cabal 3.6 [#1754](https://github.com/yesodweb/yesod/pull/1754)
|
||||
|
||||
## 1.6.2
|
||||
|
||||
* aeson 2.0
|
||||
|
||||
## 1.6.1
|
||||
|
||||
Added command line options `cert` and `key` to allow TLS certificate and key files to be passed to `yesod devel` [#1717](https://github.com/yesodweb/yesod/pull/1717)
|
||||
|
||||
## 1.6.0.6
|
||||
|
||||
Fix the `add-handler` subcommand to support both the old default routes filename (`routes`) and the new one (`routes.yesodroutes`) [#1688](https://github.com/yesodweb/yesod/pull/1688)
|
||||
|
||||
## 1.6.0.5
|
||||
|
||||
* Use process groups to ensure GHC is killed on Ctrl-C [#1683](https://github.com/yesodweb/yesod/pull/1683)
|
||||
|
||||
## 1.6.0.4
|
||||
|
||||
* Support Cabal 3.0
|
||||
|
||||
## 1.6.0.3
|
||||
|
||||
* Support Cabal 2.2 [#1151](https://github.com/yesodweb/yesod/issues/1511)
|
||||
|
||||
## 1.6.0.2
|
||||
|
||||
* Fix broken support for older http-reverse-proxy
|
||||
|
||||
## 1.6.0.1
|
||||
|
||||
* Support for http-reverse-proxy 0.6
|
||||
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to conduit 1.3.0
|
||||
* Remove configure, build, touch, and test commands
|
||||
|
||||
## 1.5.3
|
||||
|
||||
* Support typed-process-0.2.0.0
|
||||
|
||||
## 1.5.2.6
|
||||
|
||||
* Drop an upper bound
|
||||
|
||||
## 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,145 +1,163 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Devel
|
||||
( devel
|
||||
, develSignal
|
||||
, DevelOpts(..)
|
||||
, DevelTermOpt(..)
|
||||
, defaultDevelOpts
|
||||
) 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.Compiler as D
|
||||
import qualified Distribution.ModuleName as D
|
||||
import qualified Distribution.PackageDescription as D
|
||||
#if MIN_VERSION_Cabal(3,8,0)
|
||||
import qualified Distribution.Simple.PackageDescription as D
|
||||
#endif
|
||||
#if MIN_VERSION_Cabal(2, 2, 0)
|
||||
import qualified Distribution.PackageDescription.Parsec as D
|
||||
#else
|
||||
import qualified Distribution.PackageDescription.Parse as D
|
||||
#endif
|
||||
import qualified Distribution.Simple.Configure as D
|
||||
import qualified Distribution.Simple.Program as D
|
||||
import qualified Distribution.Simple.Utils as D
|
||||
import qualified Distribution.Verbosity as D
|
||||
import Network.HTTP.Client (newManager)
|
||||
import Network.HTTP.Client (managerSetProxy,
|
||||
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
|
||||
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Concurrent.MVar (MVar, newEmptyMVar,
|
||||
takeMVar, tryPutMVar)
|
||||
import Control.Concurrent.Async (race_)
|
||||
import qualified Control.Exception as Ex
|
||||
import Control.Monad (forever, unless, void,
|
||||
when, forM)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.State (evalStateT, get)
|
||||
import qualified Data.IORef as I
|
||||
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Char (isNumber, isUpper)
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import System.Directory
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Exit (ExitCode (..),
|
||||
exitFailure,
|
||||
exitSuccess)
|
||||
import System.FilePath (dropExtension,
|
||||
splitDirectories,
|
||||
takeExtension, (</>))
|
||||
import System.FSNotify
|
||||
import System.IO (Handle)
|
||||
import System.IO.Error (isDoesNotExistError)
|
||||
import System.Posix.Types (EpochTime)
|
||||
import System.PosixCompat.Files (getFileStatus,
|
||||
modificationTime)
|
||||
import System.Process (ProcessHandle,
|
||||
createProcess, env,
|
||||
getProcessExitCode,
|
||||
proc, readProcess,
|
||||
system,
|
||||
terminateProcess)
|
||||
import System.Timeout (timeout)
|
||||
|
||||
import Build (getDeps, isNewerThan,
|
||||
recompDeps)
|
||||
import GhcBuild (buildPackage,
|
||||
getBuildFlags, getPackageArgs)
|
||||
|
||||
import qualified Config as GHC
|
||||
import Data.Streaming.Network (bindPortTCP)
|
||||
import Network (withSocketsDo)
|
||||
import Network.HTTP.Conduit (conduitManagerSettings, newManager)
|
||||
import Data.Default.Class (def)
|
||||
#if MIN_VERSION_http_client(0,4,7)
|
||||
import Network.HTTP.Client (managerSetProxy, noProxy)
|
||||
#endif
|
||||
)
|
||||
import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
|
||||
waiProxyToSettings, wpsTimeout, wpsOnExc)
|
||||
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.Socket (sClose)
|
||||
import Network.Wai (responseLBS, requestHeaders,
|
||||
requestHeaderHost)
|
||||
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
|
||||
import Network.Wai.Handler.Warp (run, defaultSettings, setPort)
|
||||
import Network.Wai.Handler.WarpTLS (runTLS, tlsSettingsMemory)
|
||||
import SrcLoc (Located)
|
||||
import Data.FileEmbed (embedFile)
|
||||
|
||||
-- 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
|
||||
lockFile :: FilePath
|
||||
lockFile = "yesod-devel/devel-terminate"
|
||||
|
||||
specialFilePath :: SpecialFile -> FilePath
|
||||
writeLock :: DevelOpts -> IO ()
|
||||
writeLock _opts = do
|
||||
createDirectoryIfMissing True "yesod-devel"
|
||||
writeFile lockFile ""
|
||||
createDirectoryIfMissing True "dist" -- for compatibility with old devel.hs
|
||||
writeFile "dist/devel-terminate" ""
|
||||
|
||||
-- used by scaffolded app, cannot change
|
||||
specialFilePath TermFile = "yesod-devel/devel-terminate"
|
||||
removeLock :: DevelOpts -> IO ()
|
||||
removeLock _opts = do
|
||||
removeFileIfExists lockFile
|
||||
removeFileIfExists "dist/devel-terminate" -- for compatibility with old devel.hs
|
||||
|
||||
-- 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 DevelTermOpt = TerminateOnEnter | TerminateOnlyInterrupt
|
||||
deriving (Show, Eq)
|
||||
|
||||
data DevelOpts = DevelOpts
|
||||
{ verbose :: Bool
|
||||
, successHook :: Maybe String
|
||||
, develPort :: Int
|
||||
, develTlsPort :: Int
|
||||
, proxyTimeout :: Int
|
||||
{ isCabalDev :: Bool
|
||||
, forceCabal :: Bool
|
||||
, verbose :: Bool
|
||||
, eventTimeout :: Int -- negative value for no timeout
|
||||
, successHook :: Maybe String
|
||||
, failHook :: Maybe String
|
||||
, buildDir :: Maybe String
|
||||
, develPort :: Int
|
||||
, develTlsPort :: Int
|
||||
, proxyTimeout :: Int
|
||||
, useReverseProxy :: Bool
|
||||
, develHost :: Maybe String
|
||||
, cert :: Maybe (FilePath, FilePath)
|
||||
, terminateWith :: DevelTermOpt
|
||||
|
||||
-- Support for GHC_PACKAGE_PATH wrapping
|
||||
, develConfigOpts :: [String]
|
||||
, develEnv :: Maybe [(String, String)]
|
||||
} 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
|
||||
getBuildDir :: DevelOpts -> String
|
||||
getBuildDir opts = fromMaybe "dist" (buildDir opts)
|
||||
|
||||
defaultDevelOpts :: DevelOpts
|
||||
defaultDevelOpts = DevelOpts
|
||||
{ isCabalDev = False
|
||||
, forceCabal = False
|
||||
, verbose = False
|
||||
, eventTimeout = -1
|
||||
, successHook = Nothing
|
||||
, failHook = Nothing
|
||||
, buildDir = Nothing
|
||||
, develPort = 3000
|
||||
, develTlsPort = 3443
|
||||
, proxyTimeout = 10
|
||||
, useReverseProxy = True
|
||||
, terminateWith = TerminateOnEnter
|
||||
, develConfigOpts = []
|
||||
, develEnv = Nothing
|
||||
}
|
||||
|
||||
cabalProgram :: DevelOpts -> FilePath
|
||||
cabalProgram opts
|
||||
| isCabalDev opts = "cabal-dev"
|
||||
| otherwise = "cabal"
|
||||
|
||||
-- | Run a reverse proxy from port 3000 to 3001. If there is no response on
|
||||
-- 3001, give an appropriate message to the user.
|
||||
reverseProxy :: DevelOpts -> I.IORef Int -> IO ()
|
||||
reverseProxy opts iappPort = do
|
||||
#if MIN_VERSION_http_client(0,4,7)
|
||||
manager <- newManager $ managerSetProxy noProxy conduitManagerSettings
|
||||
#else
|
||||
manager <- newManager conduitManagerSettings
|
||||
#endif
|
||||
let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html")
|
||||
let onExc _ req
|
||||
| maybe False (("application/json" `elem`) . parseHttpAccept)
|
||||
(lookup "accept" $ requestHeaders req) =
|
||||
@ -155,16 +173,11 @@ reverseProxy opts appPortVar = do
|
||||
|
||||
let proxyApp = waiProxyToSettings
|
||||
(const $ do
|
||||
appPort <- atomically $ readTVar appPortVar
|
||||
sayV $ "revProxy: appPort " ++ (show appPort)
|
||||
appPort <- liftIO $ I.readIORef iappPort
|
||||
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
|
||||
@ -172,14 +185,11 @@ reverseProxy opts appPortVar = do
|
||||
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 cert = $(embedFile "certificate.pem")
|
||||
key = $(embedFile "key.pem")
|
||||
tlsSettings = tlsSettingsMemory cert key
|
||||
runTLS tlsSettings (setPort port defaultSettings) $ \req send -> do
|
||||
let req' = req
|
||||
{ requestHeaders
|
||||
= ("X-Forwarded-Proto", "https")
|
||||
@ -197,337 +207,363 @@ reverseProxy opts appPortVar = do
|
||||
(requestHeaders req)
|
||||
}
|
||||
app req' send
|
||||
httpProxy = runSettings (setPort (develPort opts) defaultSettings') proxyApp
|
||||
httpProxy = run (develPort opts) 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
|
||||
putStrLn "Application can be accessed at:\n"
|
||||
putStrLn $ "http://localhost:" ++ show (develPort opts)
|
||||
putStrLn $ "https://localhost:" ++ show (develTlsPort opts)
|
||||
putStrLn $ "If you wish to test https capabilities, you should set the following variable:"
|
||||
putStrLn $ " export APPROOT=https://localhost:" ++ show (develTlsPort opts)
|
||||
putStrLn ""
|
||||
loop (race_ httpProxy httpsProxy) `Ex.catch` \e -> do
|
||||
print (e :: Ex.SomeException)
|
||||
_ <- exitFailure
|
||||
Ex.throwIO e -- heh, just for good measure
|
||||
where
|
||||
loop proxies = forever $ do
|
||||
void proxies
|
||||
putStrLn $ "Reverse proxy stopped, but it shouldn't"
|
||||
threadDelay 1000000
|
||||
putStrLn $ "Restarting reverse proxies"
|
||||
|
||||
-- | Check if the given port is available.
|
||||
checkPort :: Int -> IO Bool
|
||||
checkPort p = do
|
||||
es <- Ex.tryIO $ bindPortTCP p "*4"
|
||||
es <- Ex.try $ bindPortTCP p "*4"
|
||||
case es of
|
||||
Left _ -> return False
|
||||
Left (_ :: Ex.IOException) -> return False
|
||||
Right s -> do
|
||||
Network.Socket.close s
|
||||
sClose s
|
||||
return True
|
||||
|
||||
-- | Get a random, unused port.
|
||||
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
|
||||
getPort :: DevelOpts -> Int -> IO Int
|
||||
getPort opts _
|
||||
| not (useReverseProxy opts) = return $ develPort opts
|
||||
getPort _ p0 =
|
||||
loop p0
|
||||
where
|
||||
loop p = do
|
||||
avail <- checkPort p
|
||||
if avail then return p else loop (succ p)
|
||||
|
||||
-- | Utility function
|
||||
unlessM :: Monad m => m Bool -> m () -> m ()
|
||||
unlessM c a = c >>= \res -> unless res a
|
||||
|
||||
-- | Find the file containing the devel code to be run.
|
||||
devel :: DevelOpts -> [String] -> IO ()
|
||||
devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
|
||||
unlessM (checkPort $ develPort opts) $ error "devel port unavailable"
|
||||
iappPort <- getPort opts 17834 >>= I.newIORef
|
||||
when (useReverseProxy opts) $ void $ forkIO $ reverseProxy opts iappPort
|
||||
develHsPath <- checkDevelFile
|
||||
writeLock opts
|
||||
|
||||
let (terminator, after) = case terminateWith opts of
|
||||
TerminateOnEnter ->
|
||||
("Type 'quit'", blockQuit)
|
||||
TerminateOnlyInterrupt -> -- run for one year
|
||||
("Interrupt", threadDelay $ 1000 * 1000 * 60 * 60 * 24 * 365)
|
||||
|
||||
blockQuit = do
|
||||
s <- getLine
|
||||
if s == "quit"
|
||||
then return ()
|
||||
else do
|
||||
putStrLn "Type 'quit' to quit"
|
||||
blockQuit
|
||||
|
||||
|
||||
putStrLn $ "Yesod devel server. " ++ terminator ++ " to quit"
|
||||
void $ forkIO $ do
|
||||
filesModified <- newEmptyMVar
|
||||
void $ forkIO $
|
||||
void $ watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
|
||||
evalStateT (mainOuterLoop develHsPath iappPort filesModified) Map.empty
|
||||
after
|
||||
writeLock opts
|
||||
exitSuccess
|
||||
where
|
||||
bd = getBuildDir opts
|
||||
|
||||
-- outer loop re-reads the cabal file
|
||||
mainOuterLoop develHsPath iappPort filesModified = do
|
||||
ghcVer <- liftIO ghcVersion
|
||||
#if MIN_VERSION_Cabal(1,20,0)
|
||||
cabal <- liftIO $ D.tryFindPackageDesc "."
|
||||
#else
|
||||
cabal <- liftIO $ D.findPackageDesc "."
|
||||
#endif
|
||||
gpd <- liftIO $ D.readPackageDescription D.normal cabal
|
||||
ldar <- liftIO lookupLdAr
|
||||
(hsSourceDirs, _) <- liftIO $ checkCabalFile gpd
|
||||
liftIO $ removeFileIfExists (bd </> "setup-config")
|
||||
c <- liftIO $ configure opts passThroughArgs
|
||||
if c then do
|
||||
-- these files contain the wrong data after the configure step,
|
||||
-- remove them to force a cabal build first
|
||||
liftIO $ mapM_ removeFileIfExists [ "yesod-devel/ghcargs.txt"
|
||||
, "yesod-devel/arargs.txt"
|
||||
, "yesod-devel/ldargs.txt"
|
||||
]
|
||||
rebuild <- liftIO $ mkRebuild ghcVer cabal opts ldar
|
||||
mainInnerLoop develHsPath iappPort hsSourceDirs filesModified cabal rebuild
|
||||
else do
|
||||
liftIO (threadDelay 5000000)
|
||||
mainOuterLoop develHsPath iappPort filesModified
|
||||
|
||||
-- inner loop rebuilds after files change
|
||||
mainInnerLoop develHsPath iappPort hsSourceDirs filesModified cabal rebuild = go
|
||||
where
|
||||
go = do
|
||||
_ <- recompDeps hsSourceDirs
|
||||
list <- liftIO $ getFileList hsSourceDirs [cabal]
|
||||
success <- liftIO rebuild
|
||||
pkgArgs <- liftIO (ghcPackageArgs opts)
|
||||
let devArgs = pkgArgs ++ [develHsPath]
|
||||
let loop list0 = do
|
||||
(haskellFileChanged, list1) <- liftIO $
|
||||
watchForChanges filesModified hsSourceDirs [cabal] list0 (eventTimeout opts)
|
||||
anyTouched <- recompDeps hsSourceDirs
|
||||
unless (anyTouched || haskellFileChanged) $ loop list1
|
||||
if not success
|
||||
then liftIO $ do
|
||||
putStrLn "\x1b[1;31mBuild failure, pausing...\x1b[0m"
|
||||
runBuildHook $ failHook opts
|
||||
else do
|
||||
liftIO $ runBuildHook $ successHook opts
|
||||
liftIO $ removeLock opts
|
||||
liftIO $ putStrLn
|
||||
$ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs
|
||||
else "Starting development server..."
|
||||
env0 <- liftIO getEnvironment
|
||||
|
||||
-- get a new port for the new process to listen on
|
||||
appPort <- liftIO $ I.readIORef iappPort >>= getPort opts . (+ 1)
|
||||
liftIO $ I.writeIORef iappPort appPort
|
||||
|
||||
(_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs)
|
||||
{ env = Just $ Map.toList
|
||||
$ Map.insert "PORT" (show appPort)
|
||||
$ Map.insert "DISPLAY_PORT" (show $ develPort opts)
|
||||
$ Map.fromList env0
|
||||
}
|
||||
derefMap <- get
|
||||
watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do
|
||||
loop list
|
||||
liftIO $ do
|
||||
putStrLn "Stopping development server..."
|
||||
writeLock opts
|
||||
threadDelay 1000000
|
||||
putStrLn "Terminating development server..."
|
||||
terminateProcess ph
|
||||
ec <- liftIO $ waitForProcess' ph
|
||||
liftIO $ putStrLn $ "Exit code: " ++ show ec
|
||||
liftIO $ Ex.throwTo watchTid (userError "process finished")
|
||||
loop list
|
||||
n <- liftIO $ cabal `isNewerThan` (bd </> "setup-config")
|
||||
if n then mainOuterLoop develHsPath iappPort filesModified else go
|
||||
|
||||
runBuildHook :: Maybe String -> IO ()
|
||||
runBuildHook (Just s) = do
|
||||
ret <- system s
|
||||
case ret of
|
||||
ExitFailure _ -> putStrLn ("Error executing hook: " ++ s)
|
||||
_ -> return ()
|
||||
runBuildHook Nothing = return ()
|
||||
|
||||
{-
|
||||
run `cabal configure' with our wrappers
|
||||
-}
|
||||
configure :: DevelOpts -> [String] -> IO Bool
|
||||
configure opts extraArgs =
|
||||
checkExit =<< createProcess (proc (cabalProgram opts) $
|
||||
[ "configure"
|
||||
, "-flibrary-only"
|
||||
, "--disable-tests"
|
||||
, "--disable-benchmarks"
|
||||
, "-fdevel"
|
||||
, "--disable-library-profiling"
|
||||
, "--with-ld=yesod-ld-wrapper"
|
||||
, "--with-ghc=yesod-ghc-wrapper"
|
||||
, "--with-ar=yesod-ar-wrapper"
|
||||
, "--with-hc-pkg=ghc-pkg"
|
||||
] ++ develConfigOpts opts ++ extraArgs
|
||||
) { env = develEnv opts }
|
||||
|
||||
removeFileIfExists :: FilePath -> IO ()
|
||||
removeFileIfExists file = removeFile file `Ex.catch` handler
|
||||
where
|
||||
handler :: IOError -> IO ()
|
||||
handler e | isDoesNotExistError e = return ()
|
||||
| otherwise = Ex.throw e
|
||||
|
||||
mkRebuild :: String -> FilePath -> DevelOpts -> (FilePath, FilePath) -> IO (IO Bool)
|
||||
mkRebuild ghcVer cabalFile opts (ldPath, arPath)
|
||||
| GHC.cProjectVersion /= ghcVer =
|
||||
failWith "Yesod has been compiled with a different GHC version, please reinstall yesod-bin"
|
||||
| forceCabal opts = return (rebuildCabal opts)
|
||||
| otherwise =
|
||||
return $ do
|
||||
ns <- mapM (cabalFile `isNewerThan`)
|
||||
[ "yesod-devel/ghcargs.txt", "yesod-devel/arargs.txt", "yesod-devel/ldargs.txt" ]
|
||||
if or ns
|
||||
then rebuildCabal opts
|
||||
else do
|
||||
bf <- getBuildFlags
|
||||
rebuildGhc bf ldPath arPath
|
||||
|
||||
|
||||
rebuildGhc :: [Located String] -> FilePath -> FilePath -> IO Bool
|
||||
rebuildGhc bf ld ar = do
|
||||
putStrLn "Rebuilding application... (using GHC API)"
|
||||
buildPackage bf ld ar
|
||||
|
||||
rebuildCabal :: DevelOpts -> IO Bool
|
||||
rebuildCabal opts = do
|
||||
putStrLn $ "Rebuilding application... (using " ++ cabalProgram opts ++ ")"
|
||||
checkExit =<< createProcess (proc (cabalProgram opts) args)
|
||||
{ env = develEnv opts
|
||||
}
|
||||
where
|
||||
args | verbose opts = [ "build" ]
|
||||
| otherwise = [ "build", "-v0" ]
|
||||
|
||||
try_ :: forall a. IO a -> IO ()
|
||||
try_ x = void (Ex.try x :: IO (Either Ex.SomeException a))
|
||||
|
||||
type FileList = Map.Map FilePath EpochTime
|
||||
|
||||
getFileList :: [FilePath] -> [FilePath] -> IO FileList
|
||||
getFileList hsSourceDirs extraFiles = do
|
||||
(files, deps) <- getDeps hsSourceDirs
|
||||
let files' = extraFiles ++ files ++ map fst (Map.toList deps)
|
||||
fmap Map.fromList $ forM files' $ \f -> do
|
||||
efs <- Ex.try $ getFileStatus f
|
||||
return $ case efs of
|
||||
Left (_ :: Ex.SomeException) -> (f, 0)
|
||||
Right fs -> (f, modificationTime fs)
|
||||
|
||||
-- | Returns @True@ if a .hs file changed.
|
||||
watchForChanges :: MVar () -> [FilePath] -> [FilePath] -> FileList -> Int -> IO (Bool, FileList)
|
||||
watchForChanges filesModified hsSourceDirs extraFiles list t = do
|
||||
newList <- getFileList hsSourceDirs extraFiles
|
||||
if list /= newList
|
||||
then do
|
||||
let haskellFileChanged = not $ Map.null $ Map.filterWithKey isHaskell $
|
||||
Map.differenceWith compareTimes newList list `Map.union`
|
||||
Map.differenceWith compareTimes list newList
|
||||
return (haskellFileChanged, newList)
|
||||
else timeout (1000000*t) (takeMVar filesModified) >>
|
||||
watchForChanges filesModified hsSourceDirs extraFiles list t
|
||||
where
|
||||
compareTimes x y
|
||||
| x == y = Nothing
|
||||
| otherwise = Just x
|
||||
|
||||
isHaskell filename _ = takeExtension filename `elem` [".hs", ".lhs", ".hsc", ".cabal"]
|
||||
|
||||
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 [] = failWith $ "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"
|
||||
checkCabalFile :: D.GenericPackageDescription -> IO ([FilePath], D.Library)
|
||||
checkCabalFile gpd = case D.condLibrary gpd of
|
||||
Nothing -> failWith "incorrect cabal file, no library"
|
||||
Just ct ->
|
||||
case lookupDevelLib gpd ct of
|
||||
Nothing ->
|
||||
failWith "no development flag found in your configuration file. Expected a 'library-only' flag or the older 'devel' flag"
|
||||
Just dLib -> do
|
||||
let hsSourceDirs = D.hsSourceDirs . D.libBuildInfo $ dLib
|
||||
fl <- getFileList hsSourceDirs []
|
||||
let unlisted = checkFileList fl dLib
|
||||
unless (null unlisted) $ do
|
||||
putStrLn "WARNING: the following source files are not listed in exposed-modules or other-modules:"
|
||||
mapM_ putStrLn unlisted
|
||||
when ("Application" `notElem` (map (last . D.components) $ D.exposedModules dLib)) $
|
||||
putStrLn "WARNING: no exposed module Application"
|
||||
return (hsSourceDirs, dLib)
|
||||
|
||||
stackFailureString :: ByteString
|
||||
stackFailureString = "ExitFailure"
|
||||
failWith :: String -> IO a
|
||||
failWith msg = do
|
||||
putStrLn $ "ERROR: " ++ msg
|
||||
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
|
||||
checkFileList :: FileList -> D.Library -> [FilePath]
|
||||
checkFileList fl lib = filter (not . isSetup) . filter isUnlisted . filter isSrcFile $ sourceFiles
|
||||
where
|
||||
#if MIN_VERSION_Cabal(2, 0, 0)
|
||||
unFlagName = D.unFlagName
|
||||
#else
|
||||
unFlagName (D.FlagName fn) = fn
|
||||
#endif
|
||||
al = allModules lib
|
||||
-- a file is only a possible 'module file' if all path pieces start with a capital letter
|
||||
sourceFiles = filter isSrcFile . map fst . Map.toList $ fl
|
||||
isSrcFile file = let dirs = filter (/=".") $ splitDirectories file
|
||||
in all (isUpper . head) dirs && (takeExtension file `elem` [".hs", ".lhs"])
|
||||
isUnlisted file = not (toModuleName file `Set.member` al)
|
||||
toModuleName = L.intercalate "." . filter (/=".") . splitDirectories . dropExtension
|
||||
|
||||
-- | 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"
|
||||
isSetup "Setup.hs" = True
|
||||
isSetup "./Setup.hs" = True
|
||||
isSetup "Setup.lhs" = True
|
||||
isSetup "./Setup.lhs" = True
|
||||
isSetup _ = False
|
||||
|
||||
-- Friendly message to the user
|
||||
say "Yesod devel server. Enter 'quit' or hit Ctrl-C to quit."
|
||||
allModules :: D.Library -> Set.Set String
|
||||
allModules lib = Set.fromList $ map toString $ D.exposedModules lib ++ (D.otherModules . D.libBuildInfo) lib
|
||||
where
|
||||
toString = L.intercalate "." . D.components
|
||||
|
||||
-- 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
|
||||
ghcVersion :: IO String
|
||||
ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] []
|
||||
where
|
||||
getNumber = filter (\x -> isNumber x || x == '.')
|
||||
|
||||
#if MIN_VERSION_Cabal(2, 0, 0)
|
||||
gpd <- D.readGenericPackageDescription D.normal cabal
|
||||
#else
|
||||
gpd <- D.readPackageDescription D.normal cabal
|
||||
#endif
|
||||
ghcPackageArgs :: DevelOpts -> IO [String]
|
||||
ghcPackageArgs opts = getBuildFlags >>= getPackageArgs (buildDir opts)
|
||||
|
||||
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)
|
||||
lookupDevelLib :: D.GenericPackageDescription -> D.CondTree D.ConfVar c a -> Maybe a
|
||||
lookupDevelLib gpd ct | found = Just (D.condTreeData ct)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
-- say, but only when verbose is on
|
||||
sayV = when (verbose opts) . sayString
|
||||
flags = map (unFlagName . D.flagName) $ D.genPackageFlags gpd
|
||||
unFlagName (D.FlagName x) = x
|
||||
found = any (`elem` ["library-only", "devel"]) flags
|
||||
|
||||
-- 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"
|
||||
-- location of `ld' and `ar' programs
|
||||
lookupLdAr :: IO (FilePath, FilePath)
|
||||
lookupLdAr = do
|
||||
mla <- lookupLdAr'
|
||||
case mla of
|
||||
Nothing -> failWith "Cannot determine location of `ar' or `ld' program"
|
||||
Just la -> return la
|
||||
|
||||
-- Indicate the component we want
|
||||
, packageName ++ ":lib"
|
||||
lookupLdAr' :: IO (Maybe (FilePath, FilePath))
|
||||
lookupLdAr' = do
|
||||
#if MIN_VERSION_Cabal(1,18,0)
|
||||
(_, _, pgmc) <- D.configCompilerEx (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent
|
||||
#else
|
||||
(_, pgmc) <- D.configCompiler (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent
|
||||
#endif
|
||||
pgmc' <- D.configureAllKnownPrograms D.silent pgmc
|
||||
return $ (,) <$> look D.ldProgram pgmc' <*> look D.arProgram pgmc'
|
||||
where
|
||||
look pgm pdb = fmap D.programPath (D.lookupProgram pgm pdb)
|
||||
|
||||
-- signal the watcher that a build has succeeded
|
||||
, "--exec", myPath ++ " devel-signal"
|
||||
] ++
|
||||
-- | nonblocking version of @waitForProcess@
|
||||
waitForProcess' :: ProcessHandle -> IO ExitCode
|
||||
waitForProcess' pid = go
|
||||
where
|
||||
go = do
|
||||
mec <- getProcessExitCode pid
|
||||
case mec of
|
||||
Just ec -> return ec
|
||||
Nothing -> threadDelay 100000 >> go
|
||||
|
||||
-- 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
|
||||
-- | wait for process started by @createProcess@, return True for ExitSuccess
|
||||
checkExit :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO Bool
|
||||
checkExit (_,_,_,h) = (==ExitSuccess) <$> waitForProcess' h
|
||||
|
||||
547
yesod-bin/GhcBuild.hs
Normal file
547
yesod-bin/GhcBuild.hs
Normal file
@ -0,0 +1,547 @@
|
||||
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
|
||||
{-
|
||||
There is a lot of code copied from GHC here, and some conditional
|
||||
compilation. Instead of fixing all warnings and making it much more
|
||||
difficult to compare the code to the original, just ignore unused
|
||||
binds and imports.
|
||||
-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
{-
|
||||
build package with the GHC API
|
||||
-}
|
||||
|
||||
module GhcBuild (getBuildFlags, buildPackage, getPackageArgs) where
|
||||
|
||||
import qualified Control.Exception as Ex
|
||||
import Control.Monad (when)
|
||||
import Data.IORef
|
||||
import System.Process (rawSystem)
|
||||
import System.Environment (getEnvironment)
|
||||
|
||||
import CmdLineParser
|
||||
import Data.Char (toLower)
|
||||
import Data.List (isPrefixOf, isSuffixOf, partition)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import DriverPhases (Phase (..), anyHsc, isHaskellSrcFilename,
|
||||
isSourceFilename, startPhase)
|
||||
import DriverPipeline (compileFile, link, linkBinary, oneShot)
|
||||
import DynFlags (DynFlags, compilerInfo)
|
||||
import qualified DynFlags
|
||||
import qualified DynFlags as DF
|
||||
import qualified GHC
|
||||
import GHC.Paths (libdir)
|
||||
import HscTypes (HscEnv (..), emptyHomePackageTable)
|
||||
import qualified Module
|
||||
import MonadUtils (liftIO)
|
||||
import Panic (throwGhcException, panic)
|
||||
import SrcLoc (Located, mkGeneralLocated)
|
||||
import qualified StaticFlags
|
||||
#if __GLASGOW_HASKELL__ >= 707
|
||||
import DynFlags (ldInputs)
|
||||
#else
|
||||
import StaticFlags (v_Ld_inputs)
|
||||
#endif
|
||||
import System.FilePath (normalise, (</>))
|
||||
import Util (consIORef, looksLikeModuleName)
|
||||
|
||||
{-
|
||||
This contains a huge hack:
|
||||
GHC only accepts setting static flags once per process, however it has no way to
|
||||
get the remaining options from the command line, without setting the static flags.
|
||||
This code overwrites the IORef to disable the check. This will likely cause
|
||||
problems if the flags are modified, but fortunately that's relatively uncommon.
|
||||
-}
|
||||
getBuildFlags :: IO [Located String]
|
||||
getBuildFlags = do
|
||||
argv0 <- fmap read $ readFile "yesod-devel/ghcargs.txt" -- generated by yesod-ghc-wrapper
|
||||
argv0' <- prependHsenvArgv argv0
|
||||
let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0'
|
||||
mbMinusB | null minusB_args = Nothing
|
||||
| otherwise = Just (drop 2 (last minusB_args))
|
||||
let argv1' = map (mkGeneralLocated "on the commandline") argv1
|
||||
writeIORef StaticFlags.v_opt_C_ready False -- the huge hack
|
||||
(argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1'
|
||||
return argv2
|
||||
|
||||
prependHsenvArgv :: [String] -> IO [String]
|
||||
prependHsenvArgv argv = do
|
||||
env <- getEnvironment
|
||||
return $ case (lookup "HSENV" env) of
|
||||
Nothing -> argv
|
||||
_ -> hsenvArgv ++ argv
|
||||
where hsenvArgv = words $ fromMaybe "" (lookup "PACKAGE_DB_FOR_GHC" env)
|
||||
|
||||
-- construct a command line for loading the right packages
|
||||
getPackageArgs :: Maybe String -> [Located String] -> IO [String]
|
||||
getPackageArgs buildDir argv2 = do
|
||||
(mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
|
||||
GHC.runGhc (Just libdir) $ do
|
||||
dflags0 <- GHC.getSessionDynFlags
|
||||
(dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3
|
||||
let pkgFlags = map convertPkgFlag (GHC.packageFlags dflags1)
|
||||
ignorePkgFlags =
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
map convertIgnorePkgFlag (GHC.ignorePackageFlags dflags1)
|
||||
#else
|
||||
[]
|
||||
#endif
|
||||
trustPkgFlags =
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
map convertTrustPkgFlag (GHC.trustFlags dflags1)
|
||||
#else
|
||||
[]
|
||||
#endif
|
||||
hideAll | gopt DF.Opt_HideAllPackages dflags1 = [ "-hide-all-packages"]
|
||||
| otherwise = []
|
||||
ownPkg = packageString (DF.thisPackage dflags1)
|
||||
return (reverse (extra dflags1) ++ hideAll ++ trustPkgFlags ++ ignorePkgFlags ++ pkgFlags ++ ownPkg)
|
||||
where
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
convertIgnorePkgFlag (DF.IgnorePackage p) = "-ignore-package" ++ p
|
||||
convertTrustPkgFlag (DF.TrustPackage p) = "-trust" ++ p
|
||||
convertTrustPkgFlag (DF.DistrustPackage p) = "-distrust" ++ p
|
||||
#else
|
||||
convertPkgFlag (DF.IgnorePackage p) = "-ignore-package" ++ p
|
||||
convertPkgFlag (DF.TrustPackage p) = "-trust" ++ p
|
||||
convertPkgFlag (DF.DistrustPackage p) = "-distrust" ++ p
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
convertPkgFlag (DF.ExposePackage _ (DF.PackageArg p) _) = "-package" ++ p
|
||||
convertPkgFlag (DF.ExposePackage _ (DF.UnitIdArg p) _) = "-package-id" ++ p
|
||||
#elif __GLASGOW_HASKELL__ == 710
|
||||
convertPkgFlag (DF.ExposePackage (DF.PackageArg p) _) = "-package" ++ p
|
||||
convertPkgFlag (DF.ExposePackage (DF.PackageIdArg p) _) = "-package-id" ++ p
|
||||
convertPkgFlag (DF.ExposePackage (DF.PackageKeyArg p) _) = "-package-key" ++ p
|
||||
#else
|
||||
convertPkgFlag (DF.ExposePackage p) = "-package" ++ p
|
||||
convertPkgFlag (DF.ExposePackageId p) = "-package-id" ++ p
|
||||
#endif
|
||||
convertPkgFlag (DF.HidePackage p) = "-hide-package" ++ p
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
-- See: https://github.com/yesodweb/yesod/issues/1284
|
||||
packageString _flags = []
|
||||
--packageString flags = "-package-id" ++ Module.unitIdString flags
|
||||
#elif __GLASGOW_HASKELL__ == 710
|
||||
packageString flags = ["-package-key" ++ Module.packageKeyString flags]
|
||||
#else
|
||||
packageString flags = ["-package-id" ++ Module.packageIdString flags ++ "-inplace"]
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 705
|
||||
extra df = inplaceConf ++ extra'
|
||||
where
|
||||
extra' = concatMap convertExtra (extraConfs df)
|
||||
-- old cabal-install sometimes misses the .inplace db, fix it here
|
||||
inplaceConf
|
||||
| any (".inplace" `isSuffixOf`) extra' = []
|
||||
| otherwise = ["-package-db" ++ fromMaybe "dist" buildDir
|
||||
++ "/package.conf.inplace"]
|
||||
extraConfs df = GHC.extraPkgConfs df []
|
||||
convertExtra DF.GlobalPkgConf = [ ]
|
||||
convertExtra DF.UserPkgConf = [ ]
|
||||
convertExtra (DF.PkgConfFile file) = [ "-package-db" ++ file ]
|
||||
#else
|
||||
extra df = inplaceConf ++ extra'
|
||||
where
|
||||
extra' = map ("-package-conf"++) (GHC.extraPkgConfs df)
|
||||
-- old cabal-install sometimes misses the .inplace db, fix it here
|
||||
inplaceConf
|
||||
| any (".inplace" `isSuffixOf`) extra' = []
|
||||
| otherwise = ["-package-conf" ++ fromMaybe "dist" buildDir
|
||||
++ "/package.conf.inplace"]
|
||||
#endif
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 707
|
||||
gopt = DF.gopt
|
||||
#else
|
||||
gopt = DF.dopt
|
||||
#endif
|
||||
|
||||
|
||||
buildPackage :: [Located String] -> FilePath -> FilePath -> IO Bool
|
||||
buildPackage a ld ar = buildPackage' a ld ar `Ex.catch` \e -> do
|
||||
putStrLn ("exception building package: " ++ show (e :: Ex.SomeException))
|
||||
return False
|
||||
|
||||
buildPackage' :: [Located String] -> FilePath -> FilePath -> IO Bool
|
||||
buildPackage' argv2 ld ar = do
|
||||
(mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
|
||||
GHC.runGhc (Just libdir) $ do
|
||||
dflags0 <- GHC.getSessionDynFlags
|
||||
(dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3
|
||||
let dflags2 = dflags1 { GHC.ghcMode = GHC.CompManager
|
||||
, GHC.hscTarget = GHC.hscTarget dflags1
|
||||
, GHC.ghcLink = GHC.LinkBinary
|
||||
, GHC.verbosity = 1
|
||||
}
|
||||
(dflags3, fileish_args, _) <- GHC.parseDynamicFlags dflags2 argv3
|
||||
GHC.setSessionDynFlags dflags3
|
||||
let normal_fileish_paths = map (normalise . GHC.unLoc) fileish_args
|
||||
(srcs, objs) = partition_args normal_fileish_paths [] []
|
||||
(hs_srcs, non_hs_srcs) = partition haskellish srcs
|
||||
haskellish (f,Nothing) =
|
||||
looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
|
||||
haskellish (_,Just phase) =
|
||||
#if MIN_VERSION_ghc(8,0,0)
|
||||
phase `notElem` [As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm, StopLn]
|
||||
#elif MIN_VERSION_ghc(7,8,3)
|
||||
phase `notElem` [As True, As False, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
|
||||
#elif MIN_VERSION_ghc(7,4,0)
|
||||
phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
|
||||
#else
|
||||
phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
|
||||
#endif
|
||||
hsc_env <- GHC.getSession
|
||||
-- if (null hs_srcs)
|
||||
-- then liftIO (oneShot hsc_env StopLn srcs)
|
||||
-- else do
|
||||
#if MIN_VERSION_ghc(7,2,0)
|
||||
o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
|
||||
#else
|
||||
o_files <- mapM (\x -> compileFile hsc_env StopLn x)
|
||||
#endif
|
||||
non_hs_srcs
|
||||
#if __GLASGOW_HASKELL__ >= 707
|
||||
let dflags4 = dflags3
|
||||
{ ldInputs = map (DF.FileOption "") (reverse o_files)
|
||||
++ ldInputs dflags3
|
||||
}
|
||||
GHC.setSessionDynFlags dflags4
|
||||
#else
|
||||
liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
|
||||
#endif
|
||||
targets <- mapM (uncurry GHC.guessTarget) hs_srcs
|
||||
GHC.setTargets targets
|
||||
ok_flag <- GHC.load GHC.LoadAllTargets
|
||||
if GHC.failed ok_flag
|
||||
then return False
|
||||
else liftIO (linkPkg ld ar) >> return True
|
||||
|
||||
linkPkg :: FilePath -> FilePath -> IO ()
|
||||
linkPkg ld ar = do
|
||||
arargs <- fmap read $ readFile "yesod-devel/arargs.txt"
|
||||
rawSystem ar arargs
|
||||
ldargs <- fmap read $ readFile "yesod-devel/ldargs.txt"
|
||||
rawSystem ld ldargs
|
||||
return ()
|
||||
|
||||
--------------------------------------------------------------------------------------------
|
||||
-- stuff below copied from ghc main.hs
|
||||
--------------------------------------------------------------------------------------------
|
||||
|
||||
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
|
||||
-> ([(String, Maybe Phase)], [String])
|
||||
partition_args [] srcs objs = (reverse srcs, reverse objs)
|
||||
partition_args ("-x":suff:args) srcs objs
|
||||
| "none" <- suff = partition_args args srcs objs
|
||||
| StopLn <- phase = partition_args args srcs (slurp ++ objs)
|
||||
| otherwise = partition_args rest (these_srcs ++ srcs) objs
|
||||
where phase = startPhase suff
|
||||
(slurp,rest) = break (== "-x") args
|
||||
these_srcs = zip slurp (repeat (Just phase))
|
||||
partition_args (arg:args) srcs objs
|
||||
| looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
|
||||
| otherwise = partition_args args srcs (arg:objs)
|
||||
|
||||
{-
|
||||
We split out the object files (.o, .dll) and add them
|
||||
to v_Ld_inputs for use by the linker.
|
||||
|
||||
The following things should be considered compilation manager inputs:
|
||||
|
||||
- haskell source files (strings ending in .hs, .lhs or other
|
||||
haskellish extension),
|
||||
|
||||
- module names (not forgetting hierarchical module names),
|
||||
|
||||
- and finally we consider everything not containing a '.' to be
|
||||
a comp manager input, as shorthand for a .hs or .lhs filename.
|
||||
|
||||
Everything else is considered to be a linker object, and passed
|
||||
straight through to the linker.
|
||||
-}
|
||||
looks_like_an_input :: String -> Bool
|
||||
looks_like_an_input m = isSourceFilename m
|
||||
|| looksLikeModuleName m
|
||||
|| '.' `notElem` m
|
||||
|
||||
|
||||
|
||||
-- Parsing the mode flag
|
||||
|
||||
parseModeFlags :: [Located String]
|
||||
-> IO (Mode,
|
||||
[Located String],
|
||||
[Located String])
|
||||
parseModeFlags args = do
|
||||
let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
|
||||
runCmdLine (processArgs mode_flags args)
|
||||
(Nothing, [], [])
|
||||
mode = case mModeFlag of
|
||||
Nothing -> doMakeMode
|
||||
Just (m, _) -> m
|
||||
errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
errorsToGhcException' = errorsToGhcException . map (\(GHC.L _ e) -> ("on the commandline", e))
|
||||
#else
|
||||
errorsToGhcException' = errorsToGhcException
|
||||
#endif
|
||||
|
||||
when (not (null errs)) $ throwGhcException $ errorsToGhcException' errs
|
||||
return (mode, flags' ++ leftover, warns)
|
||||
|
||||
type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
|
||||
-- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
|
||||
-- so we collect the new ones and return them.
|
||||
|
||||
mode_flags :: [Flag ModeM]
|
||||
mode_flags =
|
||||
[ ------- help / version ----------------------------------------------
|
||||
mkFlag "?" (PassFlag (setMode showGhcUsageMode))
|
||||
, mkFlag "-help" (PassFlag (setMode showGhcUsageMode))
|
||||
, mkFlag "V" (PassFlag (setMode showVersionMode))
|
||||
, mkFlag "-version" (PassFlag (setMode showVersionMode))
|
||||
, mkFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))
|
||||
, mkFlag "-info" (PassFlag (setMode showInfoMode))
|
||||
, mkFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
|
||||
, mkFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
|
||||
] ++
|
||||
[ mkFlag k' (PassFlag (setMode (printSetting k)))
|
||||
| k <- ["Project version",
|
||||
"Booter version",
|
||||
"Stage",
|
||||
"Build platform",
|
||||
"Host platform",
|
||||
"Target platform",
|
||||
"Have interpreter",
|
||||
"Object splitting supported",
|
||||
"Have native code generator",
|
||||
"Support SMP",
|
||||
"Unregisterised",
|
||||
"Tables next to code",
|
||||
"RTS ways",
|
||||
"Leading underscore",
|
||||
"Debug on",
|
||||
"LibDir",
|
||||
"Global Package DB",
|
||||
"C compiler flags",
|
||||
"Gcc Linker flags",
|
||||
"Ld Linker flags"],
|
||||
let k' = "-print-" ++ map (replaceSpace . toLower) k
|
||||
replaceSpace ' ' = '-'
|
||||
replaceSpace c = c
|
||||
] ++
|
||||
------- interfaces ----------------------------------------------------
|
||||
[ mkFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
|
||||
"--show-iface"))
|
||||
|
||||
------- primary modes ------------------------------------------------
|
||||
, mkFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
|
||||
addFlag "-no-link" f))
|
||||
, mkFlag "M" (PassFlag (setMode doMkDependHSMode))
|
||||
, mkFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
|
||||
, mkFlag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
|
||||
addFlag "-fvia-C" f))
|
||||
#if MIN_VERSION_ghc(7,8,3)
|
||||
, mkFlag "S" (PassFlag (setMode (stopBeforeMode (As True))))
|
||||
#else
|
||||
, mkFlag "S" (PassFlag (setMode (stopBeforeMode As)))
|
||||
#endif
|
||||
, mkFlag "-make" (PassFlag (setMode doMakeMode))
|
||||
, mkFlag "-interactive" (PassFlag (setMode doInteractiveMode))
|
||||
, mkFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))
|
||||
, mkFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
|
||||
]
|
||||
#if MIN_VERSION_ghc(7,10,1)
|
||||
where mkFlag fName fOptKind = Flag fName fOptKind AllModes
|
||||
#else
|
||||
where mkFlag fName fOptKind = Flag fName fOptKind
|
||||
#endif
|
||||
|
||||
setMode :: Mode -> String -> EwM ModeM ()
|
||||
setMode newMode newFlag = liftEwM $ do
|
||||
(mModeFlag, errs, flags') <- getCmdLineState
|
||||
let (modeFlag', errs') =
|
||||
case mModeFlag of
|
||||
Nothing -> ((newMode, newFlag), errs)
|
||||
Just (oldMode, oldFlag) ->
|
||||
case (oldMode, newMode) of
|
||||
-- -c/--make are allowed together, and mean --make -no-link
|
||||
_ | isStopLnMode oldMode && isDoMakeMode newMode
|
||||
|| isStopLnMode newMode && isDoMakeMode oldMode ->
|
||||
((doMakeMode, "--make"), [])
|
||||
|
||||
-- If we have both --help and --interactive then we
|
||||
-- want showGhciUsage
|
||||
_ | isShowGhcUsageMode oldMode &&
|
||||
isDoInteractiveMode newMode ->
|
||||
((showGhciUsageMode, oldFlag), [])
|
||||
| isShowGhcUsageMode newMode &&
|
||||
isDoInteractiveMode oldMode ->
|
||||
((showGhciUsageMode, newFlag), [])
|
||||
-- Otherwise, --help/--version/--numeric-version always win
|
||||
| isDominantFlag oldMode -> ((oldMode, oldFlag), [])
|
||||
| isDominantFlag newMode -> ((newMode, newFlag), [])
|
||||
-- We need to accumulate eval flags like "-e foo -e bar"
|
||||
(Right (Right (DoEval esOld)),
|
||||
Right (Right (DoEval [eNew]))) ->
|
||||
((Right (Right (DoEval (eNew : esOld))), oldFlag),
|
||||
errs)
|
||||
-- Saying e.g. --interactive --interactive is OK
|
||||
_ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
|
||||
-- Otherwise, complain
|
||||
_ -> let err = flagMismatchErr oldFlag newFlag
|
||||
in ((oldMode, oldFlag), err : errs)
|
||||
putCmdLineState (Just modeFlag', errs', flags')
|
||||
where isDominantFlag f = isShowGhcUsageMode f ||
|
||||
isShowGhciUsageMode f ||
|
||||
isShowVersionMode f ||
|
||||
isShowNumVersionMode f
|
||||
|
||||
flagMismatchErr :: String -> String -> String
|
||||
flagMismatchErr oldFlag newFlag
|
||||
= "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
|
||||
|
||||
addFlag :: String -> String -> EwM ModeM ()
|
||||
addFlag s flag = liftEwM $ do
|
||||
(m, e, flags') <- getCmdLineState
|
||||
putCmdLineState (m, e, mkGeneralLocated loc s : flags')
|
||||
where loc = "addFlag by " ++ flag ++ " on the commandline"
|
||||
|
||||
type Mode = Either PreStartupMode PostStartupMode
|
||||
type PostStartupMode = Either PreLoadMode PostLoadMode
|
||||
|
||||
data PreStartupMode
|
||||
= ShowVersion -- ghc -V/--version
|
||||
| ShowNumVersion -- ghc --numeric-version
|
||||
| ShowSupportedExtensions -- ghc --supported-extensions
|
||||
| Print String -- ghc --print-foo
|
||||
|
||||
showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
|
||||
showVersionMode = mkPreStartupMode ShowVersion
|
||||
showNumVersionMode = mkPreStartupMode ShowNumVersion
|
||||
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
|
||||
|
||||
mkPreStartupMode :: PreStartupMode -> Mode
|
||||
mkPreStartupMode = Left
|
||||
|
||||
isShowVersionMode :: Mode -> Bool
|
||||
isShowVersionMode (Left ShowVersion) = True
|
||||
isShowVersionMode _ = False
|
||||
|
||||
isShowNumVersionMode :: Mode -> Bool
|
||||
isShowNumVersionMode (Left ShowNumVersion) = True
|
||||
isShowNumVersionMode _ = False
|
||||
|
||||
data PreLoadMode
|
||||
= ShowGhcUsage -- ghc -?
|
||||
| ShowGhciUsage -- ghci -?
|
||||
| ShowInfo -- ghc --info
|
||||
| PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
|
||||
|
||||
showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
|
||||
showGhcUsageMode = mkPreLoadMode ShowGhcUsage
|
||||
showGhciUsageMode = mkPreLoadMode ShowGhciUsage
|
||||
showInfoMode = mkPreLoadMode ShowInfo
|
||||
|
||||
printSetting :: String -> Mode
|
||||
printSetting k = mkPreLoadMode (PrintWithDynFlags f)
|
||||
where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
|
||||
#if MIN_VERSION_ghc(7,2,0)
|
||||
$ lookup k (compilerInfo dflags)
|
||||
#else
|
||||
$ fmap convertPrintable (lookup k compilerInfo)
|
||||
where
|
||||
convertPrintable (DynFlags.String s) = s
|
||||
convertPrintable (DynFlags.FromDynFlags f) = f dflags
|
||||
#endif
|
||||
|
||||
mkPreLoadMode :: PreLoadMode -> Mode
|
||||
mkPreLoadMode = Right . Left
|
||||
|
||||
isShowGhcUsageMode :: Mode -> Bool
|
||||
isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
|
||||
isShowGhcUsageMode _ = False
|
||||
|
||||
isShowGhciUsageMode :: Mode -> Bool
|
||||
isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
|
||||
isShowGhciUsageMode _ = False
|
||||
|
||||
data PostLoadMode
|
||||
= ShowInterface FilePath -- ghc --show-iface
|
||||
| DoMkDependHS -- ghc -M
|
||||
| StopBefore Phase -- ghc -E | -C | -S
|
||||
-- StopBefore StopLn is the default
|
||||
| DoMake -- ghc --make
|
||||
| DoInteractive -- ghc --interactive
|
||||
| DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
|
||||
| DoAbiHash -- ghc --abi-hash
|
||||
|
||||
doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
|
||||
doMkDependHSMode = mkPostLoadMode DoMkDependHS
|
||||
doMakeMode = mkPostLoadMode DoMake
|
||||
doInteractiveMode = mkPostLoadMode DoInteractive
|
||||
doAbiHashMode = mkPostLoadMode DoAbiHash
|
||||
|
||||
|
||||
showInterfaceMode :: FilePath -> Mode
|
||||
showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
|
||||
|
||||
stopBeforeMode :: Phase -> Mode
|
||||
stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
|
||||
|
||||
doEvalMode :: String -> Mode
|
||||
doEvalMode str = mkPostLoadMode (DoEval [str])
|
||||
|
||||
mkPostLoadMode :: PostLoadMode -> Mode
|
||||
mkPostLoadMode = Right . Right
|
||||
|
||||
isDoInteractiveMode :: Mode -> Bool
|
||||
isDoInteractiveMode (Right (Right DoInteractive)) = True
|
||||
isDoInteractiveMode _ = False
|
||||
|
||||
isStopLnMode :: Mode -> Bool
|
||||
isStopLnMode (Right (Right (StopBefore StopLn))) = True
|
||||
isStopLnMode _ = False
|
||||
|
||||
isDoMakeMode :: Mode -> Bool
|
||||
isDoMakeMode (Right (Right DoMake)) = True
|
||||
isDoMakeMode _ = False
|
||||
|
||||
#ifdef GHCI
|
||||
isInteractiveMode :: PostLoadMode -> Bool
|
||||
isInteractiveMode DoInteractive = True
|
||||
isInteractiveMode _ = False
|
||||
#endif
|
||||
|
||||
-- isInterpretiveMode: byte-code compiler involved
|
||||
isInterpretiveMode :: PostLoadMode -> Bool
|
||||
isInterpretiveMode DoInteractive = True
|
||||
isInterpretiveMode (DoEval _) = True
|
||||
isInterpretiveMode _ = False
|
||||
|
||||
needsInputsMode :: PostLoadMode -> Bool
|
||||
needsInputsMode DoMkDependHS = True
|
||||
needsInputsMode (StopBefore _) = True
|
||||
needsInputsMode DoMake = True
|
||||
needsInputsMode _ = False
|
||||
|
||||
-- True if we are going to attempt to link in this mode.
|
||||
-- (we might not actually link, depending on the GhcLink flag)
|
||||
isLinkMode :: PostLoadMode -> Bool
|
||||
isLinkMode (StopBefore StopLn) = True
|
||||
isLinkMode DoMake = True
|
||||
isLinkMode DoInteractive = True
|
||||
isLinkMode (DoEval _) = True
|
||||
isLinkMode _ = False
|
||||
|
||||
isCompManagerMode :: PostLoadMode -> Bool
|
||||
isCompManagerMode DoMake = True
|
||||
isCompManagerMode DoInteractive = True
|
||||
isCompManagerMode (DoEval _) = True
|
||||
isCompManagerMode _ = False
|
||||
@ -2,17 +2,20 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module HsFile (mkHsFile) where
|
||||
import Text.ProjectTemplate (createTemplate)
|
||||
import Conduit
|
||||
import Data.Conduit
|
||||
( ($$), (=$), awaitForever)
|
||||
import Data.Conduit.Filesystem (sourceDirectory)
|
||||
import Control.Monad.Trans.Resource (runResourceT)
|
||||
import qualified Data.Conduit.List as CL
|
||||
import qualified Data.ByteString as BS
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.String (fromString)
|
||||
|
||||
mkHsFile :: IO ()
|
||||
mkHsFile = runConduitRes
|
||||
$ sourceDirectory "."
|
||||
.| readIt
|
||||
.| createTemplate
|
||||
.| mapM_C (liftIO . BS.putStr)
|
||||
mkHsFile = runResourceT $ sourceDirectory "."
|
||||
$$ readIt
|
||||
=$ createTemplate
|
||||
=$ awaitForever (liftIO . BS.putStr)
|
||||
where
|
||||
-- Reads a filepath from upstream and dumps a pair of (filepath, filecontents)
|
||||
readIt = mapC $ \i -> (fromString i, liftIO $ BS.readFile i)
|
||||
readIt = CL.map $ \i -> (fromString i, liftIO $ BS.readFile i)
|
||||
|
||||
@ -1,16 +1,10 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Keter
|
||||
( keter
|
||||
) where
|
||||
|
||||
import Data.Yaml
|
||||
|
||||
#if MIN_VERSION_aeson(2, 0, 0)
|
||||
import qualified Data.Aeson.KeyMap as Map
|
||||
#else
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Exit
|
||||
|
||||
@ -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:
|
||||
|
||||
|
||||
|
||||
## 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.
|
||||
1
yesod-bin/devel-example/.gitignore
vendored
1
yesod-bin/devel-example/.gitignore
vendored
@ -1 +0,0 @@
|
||||
yesod-devel/
|
||||
@ -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`
|
||||
@ -1,2 +0,0 @@
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
@ -1,6 +0,0 @@
|
||||
module Main where
|
||||
|
||||
import DevelExample
|
||||
|
||||
main :: IO ()
|
||||
main = prodMain
|
||||
@ -1,5 +0,0 @@
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
import "devel-example" DevelExample (develMain)
|
||||
|
||||
main :: IO ()
|
||||
main = develMain
|
||||
@ -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
|
||||
@ -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
|
||||
@ -1,8 +0,0 @@
|
||||
resolver: lts-7.10
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ..
|
||||
|
||||
extra-deps:
|
||||
- typed-process-0.1.0.0
|
||||
65
yesod-bin/ghcwrapper.hs
Normal file
65
yesod-bin/ghcwrapper.hs
Normal file
@ -0,0 +1,65 @@
|
||||
{-
|
||||
wrapper executable that captures arguments to ghc, ar or ld
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Main where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
import Distribution.Compiler (CompilerFlavor (..))
|
||||
import qualified Distribution.Simple.Configure as D
|
||||
import Distribution.Simple.Program (arProgram,
|
||||
defaultProgramConfiguration,
|
||||
ghcProgram, ldProgram,
|
||||
programPath)
|
||||
import Distribution.Simple.Program.Db (configureAllKnownPrograms,
|
||||
lookupProgram)
|
||||
import Distribution.Simple.Program.Types (Program (..))
|
||||
import Distribution.Verbosity (silent)
|
||||
|
||||
import System.Directory (doesDirectoryExist)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (ExitCode (..), exitWith)
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import System.Process (rawSystem, readProcess)
|
||||
|
||||
|
||||
#ifdef LDCMD
|
||||
cmd :: Program
|
||||
cmd = ldProgram
|
||||
outFile = "yesod-devel/ldargs.txt"
|
||||
#else
|
||||
#ifdef ARCMD
|
||||
cmd :: Program
|
||||
cmd = arProgram
|
||||
outFile ="yesod-devel/arargs.txt"
|
||||
#else
|
||||
cmd :: Program
|
||||
cmd = ghcProgram
|
||||
outFile = "yesod-devel/ghcargs.txt"
|
||||
#endif
|
||||
#endif
|
||||
|
||||
runProgram :: Program -> [String] -> IO ExitCode
|
||||
runProgram pgm args = do
|
||||
#if MIN_VERSION_Cabal(1,18,0)
|
||||
(_, comp, pgmc) <- D.configCompilerEx (Just GHC) Nothing Nothing defaultProgramConfiguration silent
|
||||
#else
|
||||
(comp, pgmc) <- D.configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration silent
|
||||
#endif
|
||||
pgmc' <- configureAllKnownPrograms silent pgmc
|
||||
case lookupProgram pgm pgmc' of
|
||||
Nothing -> do
|
||||
hPutStrLn stderr ("cannot find program '" ++ programName pgm ++ "'")
|
||||
return (ExitFailure 1)
|
||||
Just p -> rawSystem (programPath p) args
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
e <- doesDirectoryExist "yesod-devel"
|
||||
when e $ writeFile outFile (show args ++ "\n")
|
||||
ex <- runProgram cmd args
|
||||
exitWith ex
|
||||
@ -1,19 +1,38 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Data.Monoid
|
||||
import Data.Version (showVersion)
|
||||
import Options.Applicative
|
||||
import System.Exit (exitFailure)
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure)
|
||||
import System.FilePath (splitSearchPath)
|
||||
import System.Process (rawSystem)
|
||||
|
||||
import AddHandler (addHandler)
|
||||
import Devel (DevelOpts (..), devel, develSignal)
|
||||
import Devel (DevelOpts (..), devel, DevelTermOpt(..))
|
||||
import Keter (keter)
|
||||
import Options (injectDefaults)
|
||||
import qualified Paths_yesod_bin
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
|
||||
import HsFile (mkHsFile)
|
||||
#ifndef WINDOWS
|
||||
import Build (touch)
|
||||
|
||||
touch' :: IO ()
|
||||
touch' = touch
|
||||
|
||||
windowsWarning :: String
|
||||
windowsWarning = ""
|
||||
#else
|
||||
touch' :: IO ()
|
||||
touch' = return ()
|
||||
|
||||
windowsWarning :: String
|
||||
windowsWarning = " (does not work on Windows)"
|
||||
#endif
|
||||
|
||||
data CabalPgm = Cabal | CabalDev deriving (Show, Eq)
|
||||
|
||||
@ -29,16 +48,19 @@ data Command = Init [String]
|
||||
| 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)
|
||||
| Devel { _develDisableApi :: Bool
|
||||
, _develSuccessHook :: Maybe String
|
||||
, _develFailHook :: Maybe String
|
||||
, _develRescan :: Int
|
||||
, _develBuildDir :: Maybe String
|
||||
, develIgnore :: [String]
|
||||
, develExtraArgs :: [String]
|
||||
, _develPort :: Int
|
||||
, _develTlsPort :: Int
|
||||
, _proxyTimeout :: Int
|
||||
, _noReverseProxy :: Bool
|
||||
, _interruptOnly :: Bool
|
||||
}
|
||||
| DevelSignal
|
||||
| Test
|
||||
| AddHandler
|
||||
{ addHandlerRoute :: Maybe String
|
||||
@ -67,34 +89,61 @@ main = do
|
||||
d@Devel{} -> d { develExtraArgs = args }
|
||||
c -> c
|
||||
})
|
||||
, ("yesod.devel.ignore" , \o args -> o { optCommand =
|
||||
case optCommand o of
|
||||
d@Devel{} -> d { develIgnore = args }
|
||||
c -> c
|
||||
})
|
||||
, ("yesod.build.extracabalarg" , \o args -> o { optCommand =
|
||||
case optCommand o of
|
||||
b@Build{} -> b { buildExtraArgs = args }
|
||||
c -> c
|
||||
})
|
||||
] optParser'
|
||||
let cabal = rawSystem' (cabalCommand o)
|
||||
case optCommand o of
|
||||
Init _ -> initErrorMsg
|
||||
HsFiles -> mkHsFile
|
||||
Configure -> cabalErrorMsg
|
||||
Build _ -> cabalErrorMsg
|
||||
Touch -> cabalErrorMsg
|
||||
Configure -> cabal ["configure"]
|
||||
Build es -> touch' >> cabal ("build":es)
|
||||
Touch -> touch'
|
||||
Keter{..} -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs
|
||||
Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
|
||||
AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods
|
||||
Test -> cabalErrorMsg
|
||||
Devel{..} -> devel DevelOpts
|
||||
{ verbose = optVerbose o
|
||||
, successHook = develSuccessHook
|
||||
, develPort = develPort
|
||||
, develTlsPort = develTlsPort
|
||||
, proxyTimeout = proxyTimeout
|
||||
, useReverseProxy = not noReverseProxy
|
||||
, develHost = develHost
|
||||
, cert = cert
|
||||
} develExtraArgs
|
||||
DevelSignal -> develSignal
|
||||
Test -> cabalTest cabal
|
||||
Devel{..} ->do
|
||||
(configOpts, menv) <- handleGhcPackagePath
|
||||
let develOpts = DevelOpts
|
||||
{ isCabalDev = optCabalPgm o == CabalDev
|
||||
, forceCabal = _develDisableApi
|
||||
, verbose = optVerbose o
|
||||
, eventTimeout = _develRescan
|
||||
, successHook = _develSuccessHook
|
||||
, failHook = _develFailHook
|
||||
, buildDir = _develBuildDir
|
||||
, develPort = _develPort
|
||||
, develTlsPort = _develTlsPort
|
||||
, proxyTimeout = _proxyTimeout
|
||||
, useReverseProxy = not _noReverseProxy
|
||||
, terminateWith = if _interruptOnly then TerminateOnlyInterrupt else TerminateOnEnter
|
||||
, develConfigOpts = configOpts
|
||||
, develEnv = menv
|
||||
}
|
||||
devel develOpts develExtraArgs
|
||||
where
|
||||
cabalTest cabal = do
|
||||
env <- getEnvironment
|
||||
case lookup "STACK_EXE" env of
|
||||
Nothing -> do
|
||||
touch'
|
||||
_ <- cabal ["configure", "--enable-tests", "-flibrary-only"]
|
||||
_ <- cabal ["build"]
|
||||
cabal ["test"]
|
||||
Just _ -> do
|
||||
hPutStrLn stderr "'yesod test' is no longer needed with Stack"
|
||||
hPutStrLn stderr "Instead, please just run 'stack test'"
|
||||
exitFailure
|
||||
|
||||
initErrorMsg = do
|
||||
mapM_ putStrLn
|
||||
[ "The init command has been removed."
|
||||
@ -105,12 +154,18 @@ main = do
|
||||
]
|
||||
exitFailure
|
||||
|
||||
cabalErrorMsg = do
|
||||
mapM_ putStrLn
|
||||
[ "The configure, build, touch, and test commands have been removed."
|
||||
, "Please use 'stack' for building your project."
|
||||
]
|
||||
exitFailure
|
||||
|
||||
handleGhcPackagePath :: IO ([String], Maybe [(String, String)])
|
||||
handleGhcPackagePath = do
|
||||
env <- getEnvironment
|
||||
case lookup "GHC_PACKAGE_PATH" env of
|
||||
Nothing -> return ([], Nothing)
|
||||
Just gpp -> do
|
||||
let opts = "--package-db=clear"
|
||||
: "--package-db=global"
|
||||
: map ("--package-db=" ++)
|
||||
(drop 1 $ reverse $ splitSearchPath gpp)
|
||||
return (opts, Just $ filter (\(x, _) -> x /= "GHC_PACKAGE_PATH") env)
|
||||
|
||||
optParser' :: ParserInfo Options
|
||||
optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
|
||||
@ -124,17 +179,15 @@ optParser = Options
|
||||
<> command "hsfiles" (info (pure HsFiles)
|
||||
(progDesc "Create a hsfiles file for the current folder"))
|
||||
<> command "configure" (info (pure Configure)
|
||||
(progDesc "DEPRECATED"))
|
||||
(progDesc "Configure a project for building"))
|
||||
<> command "build" (info (helper <*> (Build <$> extraCabalArgs))
|
||||
(progDesc "DEPRECATED"))
|
||||
(progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning))
|
||||
<> command "touch" (info (pure Touch)
|
||||
(progDesc "DEPRECATED"))
|
||||
(progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning))
|
||||
<> command "devel" (info (helper <*> develOptions)
|
||||
(progDesc "Run project with the devel server"))
|
||||
<> command "devel-signal" (info (helper <*> pure DevelSignal)
|
||||
(progDesc "Used internally by the devel command"))
|
||||
<> command "test" (info (pure Test)
|
||||
(progDesc "DEPRECATED"))
|
||||
(progDesc "Build and run the integration tests"))
|
||||
<> command "add-handler" (info (helper <*> addHandlerOptions)
|
||||
(progDesc ("Add a new handler and module to the project."
|
||||
++ " Interactively asks for input if you do not specify arguments.")))
|
||||
@ -155,10 +208,26 @@ keterOptions = Keter
|
||||
where
|
||||
optStrToList m = option (words <$> str) $ value [] <> m
|
||||
|
||||
defaultRescan :: Int
|
||||
defaultRescan = 10
|
||||
|
||||
develOptions :: Parser Command
|
||||
develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
|
||||
develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
|
||||
<> help "Disable fast GHC API rebuilding")
|
||||
<*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
|
||||
<> help "Run COMMAND after rebuild succeeds")
|
||||
<*> extraStackArgs
|
||||
<*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND"
|
||||
<> help "Run COMMAND when rebuild fails")
|
||||
<*> option auto ( long "event-timeout" <> short 't' <> value defaultRescan <> metavar "N"
|
||||
<> help ("Force rescan of files every N seconds (default "
|
||||
++ show defaultRescan
|
||||
++ ", use -1 to rely on FSNotify alone)") )
|
||||
<*> optStr ( long "builddir" <> short 'b'
|
||||
<> help "Set custom cabal build directory, default `dist'")
|
||||
<*> many ( strOption ( long "ignore" <> short 'i' <> metavar "DIR"
|
||||
<> help "ignore file changes in DIR" )
|
||||
)
|
||||
<*> extraCabalArgs
|
||||
<*> option 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"
|
||||
@ -167,18 +236,8 @@ develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "C
|
||||
<> 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")
|
||||
)
|
||||
<*> switch ( long "interrupt-only" <> short 'c'
|
||||
<> help "Disable exiting when enter is pressed")
|
||||
|
||||
extraCabalArgs :: Parser [String]
|
||||
extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG"
|
||||
@ -198,3 +257,10 @@ addHandlerOptions = AddHandler
|
||||
-- | Optional @String@ argument
|
||||
optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
|
||||
optStr m = option (Just <$> str) $ value Nothing <> m
|
||||
|
||||
-- | Like @rawSystem@, but exits if it receives a non-success result.
|
||||
rawSystem' :: String -> [String] -> IO ()
|
||||
rawSystem' x y = do
|
||||
res <- rawSystem x y
|
||||
unless (res == ExitSuccess) $ exitWith res
|
||||
|
||||
|
||||
@ -1,71 +1,100 @@
|
||||
name: yesod-bin
|
||||
version: 1.6.2.2
|
||||
version: 1.4.18.7
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
maintainer: Michael Snoyman <michael@snoyman.com>
|
||||
synopsis: The yesod helper executable.
|
||||
description: See README.md for more information
|
||||
description: Provides scaffolding, devel server, and some simple code generation helpers.
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.10
|
||||
cabal-version: >= 1.6
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
data-files: refreshing.html
|
||||
|
||||
extra-source-files:
|
||||
README.md
|
||||
ChangeLog.md
|
||||
refreshing.html
|
||||
*.pem
|
||||
|
||||
executable yesod-ghc-wrapper
|
||||
main-is: ghcwrapper.hs
|
||||
build-depends:
|
||||
base >= 4 && < 5
|
||||
, Cabal
|
||||
|
||||
executable yesod-ld-wrapper
|
||||
main-is: ghcwrapper.hs
|
||||
cpp-options: -DLDCMD
|
||||
build-depends:
|
||||
base >= 4 && < 5
|
||||
, Cabal
|
||||
|
||||
executable yesod-ar-wrapper
|
||||
main-is: ghcwrapper.hs
|
||||
cpp-options: -DARCMD
|
||||
build-depends:
|
||||
base >= 4 && < 5
|
||||
, Cabal
|
||||
|
||||
executable yesod
|
||||
default-language: Haskell2010
|
||||
if os(windows)
|
||||
cpp-options: -DWINDOWS
|
||||
if os(openbsd)
|
||||
ld-options: -Wl,-zwxneeded
|
||||
|
||||
build-depends: base >= 4.10 && < 5
|
||||
, 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
|
||||
build-depends: base >= 4.3 && < 5
|
||||
, ghc >= 7.0.3
|
||||
, ghc-paths >= 0.1
|
||||
, parsec >= 2.1 && < 4
|
||||
, text >= 0.11
|
||||
, shakespeare >= 2.0
|
||||
, bytestring >= 0.9.1.4
|
||||
, time >= 1.1.4
|
||||
, template-haskell
|
||||
, directory >= 1.2.1
|
||||
, Cabal
|
||||
, unix-compat >= 0.2 && < 0.5
|
||||
, containers >= 0.2
|
||||
, attoparsec >= 0.10
|
||||
, http-types >= 0.7
|
||||
, blaze-builder >= 0.2.1.4 && < 0.5
|
||||
, filepath >= 1.1
|
||||
, process
|
||||
, zlib >= 0.5
|
||||
, tar >= 0.4 && < 0.6
|
||||
, unordered-containers
|
||||
, yaml >= 0.8 && < 0.9
|
||||
, optparse-applicative >= 0.11
|
||||
, fsnotify >= 0.0 && < 0.3
|
||||
, split >= 0.2 && < 0.3
|
||||
, file-embed
|
||||
, conduit >= 1.2
|
||||
, conduit-extra
|
||||
, resourcet >= 0.3 && < 1.2
|
||||
, base64-bytestring
|
||||
, lifted-base
|
||||
, http-reverse-proxy >= 0.4
|
||||
, network
|
||||
, http-conduit >= 2.1.4
|
||||
, http-client
|
||||
, project-template >= 0.1.1
|
||||
, transformers
|
||||
, transformers-compat
|
||||
, unliftio
|
||||
, unordered-containers
|
||||
, warp >= 1.3.7.5
|
||||
, wai >= 2.0
|
||||
, wai-extra
|
||||
, warp >= 1.3.7.5
|
||||
, data-default-class
|
||||
, streaming-commons
|
||||
, warp-tls >= 3.0.1
|
||||
, yaml >= 0.8 && < 0.12
|
||||
, zlib >= 0.5
|
||||
, aeson
|
||||
, async
|
||||
, deepseq
|
||||
|
||||
ghc-options: -Wall -threaded -rtsopts
|
||||
main-is: main.hs
|
||||
other-modules: Devel
|
||||
Build
|
||||
GhcBuild
|
||||
Keter
|
||||
AddHandler
|
||||
Paths_yesod_bin
|
||||
|
||||
@ -1,307 +1,3 @@
|
||||
# ChangeLog for yesod-core
|
||||
|
||||
## 1.6.25.1
|
||||
|
||||
* Export the options that were created in 1.6.25.0 [#1825](https://github.com/yesodweb/yesod/pull/1825)
|
||||
|
||||
## 1.6.25.0
|
||||
|
||||
* Add an options structure that allows the user to set which instances will be derived for a routes structure. [#1819](https://github.com/yesodweb/yesod/pull/1819)
|
||||
|
||||
## 1.6.24.5
|
||||
|
||||
* Support Aeson 2.2 [#1818](https://github.com/yesodweb/yesod/pull/1818)
|
||||
|
||||
## 1.6.24.4
|
||||
|
||||
* Fix test-suite compilation error for GHC >= 9.0.1 [#1812](https://github.com/yesodweb/yesod/pull/1812)
|
||||
|
||||
## 1.6.24.3
|
||||
|
||||
* Fix subsite-to-subsite dispatch [#1805](https://github.com/yesodweb/yesod/pull/1805)
|
||||
|
||||
## 1.6.24.2
|
||||
|
||||
* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
|
||||
|
||||
## 1.6.24.1
|
||||
|
||||
* Adapt to removal of `ListT` from transformers-0.6. [#1796](https://github.com/yesodweb/yesod/pull/1796)
|
||||
|
||||
## 1.6.24.0
|
||||
|
||||
* Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772).
|
||||
|
||||
## 1.6.23.1
|
||||
|
||||
* Fix typo in creation of the description `<meta>` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766)
|
||||
|
||||
## 1.6.23
|
||||
|
||||
* Add idempotent versions of `setDescription`, `setDescriptionI`. These functions
|
||||
have odd behaviour when called multiple times, so they are now warned against.
|
||||
This can't be a silent change - if you want to switch to the new functions, make
|
||||
sure your layouts are updated to use `pageDescription` as well as `pageTitle`.
|
||||
[#1765](https://github.com/yesodweb/yesod/pull/1765)
|
||||
|
||||
## 1.6.22.1
|
||||
|
||||
+ Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756)
|
||||
|
||||
## 1.6.22.0
|
||||
|
||||
* Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745)
|
||||
* Add instances for `ToContent Void`, `ToTypedContent Void`. [#1752](https://github.com/yesodweb/yesod/pull/1752)
|
||||
* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753)
|
||||
* Support template-haskell 2.18 [#1754](https://github.com/yesodweb/yesod/pull/1754)
|
||||
|
||||
## 1.6.21.0
|
||||
|
||||
* Export `Yesod.Core.Dispatch.defaultGen` so that users may reuse it for their own `YesodRunnerEnv`s [#1734](https://github.com/yesodweb/yesod/pull/1734)
|
||||
|
||||
## 1.6.20.2
|
||||
|
||||
* Fix compatibility with template-haskell 2.17 [#1729](https://github.com/yesodweb/yesod/pull/1729)
|
||||
|
||||
## 1.6.20.1
|
||||
|
||||
* Throw an error in `breadcrumbs` if the trail of breadcrumbs is circular. [#1727](https://github.com/yesodweb/yesod/issues/1727)
|
||||
|
||||
## 1.6.20
|
||||
|
||||
* Generate CSRF tokens using a secure entropy source [#1726](https://github.com/yesodweb/yesod/pull/1726)
|
||||
* Change semantics of `yreGen` and `defaultGen`
|
||||
|
||||
## 1.6.19.0
|
||||
|
||||
* Change order of priority in `languages`[#1721](https://github.com/yesodweb/yesod/pull/1721)
|
||||
|
||||
## 1.6.18.8
|
||||
|
||||
* Fix test suite for wai-extra change around vary header
|
||||
|
||||
## 1.6.18.7
|
||||
|
||||
* Fix functions generating Open Graph metadata[#1709](https://github.com/yesodweb/yesod/pull/1709)
|
||||
|
||||
## 1.6.18.6
|
||||
|
||||
* Update documentation from `HandlerT` to `HandlerFor` [#1703](https://github.com/yesodweb/yesod/pull/1703)
|
||||
|
||||
## 1.6.18.5
|
||||
|
||||
Document `ErrorResponse` [#1698](https://github.com/yesodweb/yesod/pull/1698)
|
||||
|
||||
## 1.6.18.4
|
||||
|
||||
* Fixed a bug where `mkYesod` and other TH functions didn't work for datatypes with explicitly stated type variables, including the case with typeclass constraints. [https://github.com/yesodweb/yesod/pull/1697](#1697)
|
||||
|
||||
## 1.6.18.3
|
||||
|
||||
* Remove mention of an oudated Yesod type (`GHandler`) from the docs for `handlerToIO`. [https://github.com/yesodweb/yesod/pull/1695](#1695)
|
||||
|
||||
## 1.6.18.2
|
||||
|
||||
* Recommends `.yesodroutes` as the file extension for Yesod routes files. [#1686](https://github.com/yesodweb/yesod/pull/1686)
|
||||
|
||||
## 1.6.18.1
|
||||
|
||||
* Increase the size of CSRF token
|
||||
|
||||
## 1.6.18
|
||||
|
||||
* Add functions for setting description and OG meta [#1663](https://github.com/yesodweb/yesod/pull/1663)
|
||||
|
||||
* Use `DeriveLift` to implement the `Lift` instances for `ResourceTree`,
|
||||
`Resource`, `Piece`, and `Dispatch`. Among other benefits, this provides
|
||||
implementations of `liftTyped` on `template-haskell-2.16` (GHC 8.10) or
|
||||
later. [#1664](https://github.com/yesodweb/yesod/pull/1664)
|
||||
|
||||
## 1.6.17.3
|
||||
|
||||
* Support for `unliftio-core` 0.2
|
||||
|
||||
## 1.6.17.2
|
||||
|
||||
* Support template-haskell 2.16, build with GHC 8.10 [#1657](https://github.com/yesodweb/yesod/pull/1657)
|
||||
|
||||
## 1.6.17.1
|
||||
|
||||
* Remove unnecessary deriving of Typeable
|
||||
|
||||
## 1.6.17
|
||||
|
||||
* Adds `contentTypeIsJson` [#1646](https://github.com/yesodweb/yesod/pull/1646)
|
||||
|
||||
## 1.6.16.1
|
||||
|
||||
* Compiles with GHC 8.8.1
|
||||
|
||||
## 1.6.16
|
||||
|
||||
* Add `jsAttributesHandler` to run arbitrary Handler code before building the
|
||||
attributes map for the script tag generated by `widgetFile` [#1622](https://github.com/yesodweb/yesod/pull/1622)
|
||||
|
||||
## 1.6.15
|
||||
|
||||
* Move `redirectToPost` JavaScript form submission from HTML element to
|
||||
`<script>` tag for CSP reasons [#1620](https://github.com/yesodweb/yesod/pull/1620)
|
||||
|
||||
## 1.6.14
|
||||
|
||||
* Introduce `JSONResponse`. [issue #1481](https://github.com/yesodweb/yesod/issues/1481) and [PR #1592](https://github.com/yesodweb/yesod/pull/1592)
|
||||
|
||||
## 1.6.13
|
||||
|
||||
* Introduce `maxContentLengthIO`. [issue #1588](https://github.com/yesodweb/yesod/issues/1588) and [PR #1589](https://github.com/yesodweb/yesod/pull/1589)
|
||||
|
||||
## 1.6.12
|
||||
|
||||
* Use at most one valid session cookie per request [#1581](https://github.com/yesodweb/yesod/pull/1581)
|
||||
|
||||
## 1.6.11
|
||||
|
||||
* Deprecate insecure JSON parsing functions [#1576](https://github.com/yesodweb/yesod/pull/1576)
|
||||
|
||||
## 1.6.10.1
|
||||
|
||||
* Fix test suite compilation for [commercialhaskell/stackage#4319](https://github.com/commercialhaskell/stackage/issues/4319)
|
||||
|
||||
## 1.6.10
|
||||
|
||||
* Adds functions to get and set values in the per-request caches. [#1573](https://github.com/yesodweb/yesod/pull/1573)
|
||||
|
||||
## 1.6.9
|
||||
|
||||
* Add `sendResponseNoContent` [#1565](https://github.com/yesodweb/yesod/pull/1565)
|
||||
|
||||
## 1.6.8.1
|
||||
|
||||
* Add missing test file to tarball [#1563](https://github.com/yesodweb/yesod/issues/1563)
|
||||
|
||||
## 1.6.8
|
||||
* In the route syntax, allow trailing backslashes to indicate line
|
||||
continuation. [#1558](https://github.com/yesodweb/yesod/pull/1558)
|
||||
|
||||
## 1.6.7
|
||||
|
||||
* If no matches are found, `selectRep` chooses first representation regardless
|
||||
of the presence or absence of a `Content-Type` header in the request
|
||||
[#1540](https://github.com/yesodweb/yesod/pull/1540)
|
||||
* Sets the `X-XSS-Protection` header to `1; mode=block` [#1550](https://github.com/yesodweb/yesod/pull/1550)
|
||||
* Add `PrimMonad` instances for `HandlerFor` and `WidgetFor` [from
|
||||
StackOverflow](https://stackoverflow.com/q/52692508/369198)
|
||||
|
||||
## 1.6.6
|
||||
|
||||
* `defaultErrorHandler` handles text/plain requests [#1522](https://github.com/yesodweb/yesod/pull/1520)
|
||||
|
||||
## 1.6.5
|
||||
|
||||
* Add `fileSourceByteString` [#1503](https://github.com/yesodweb/yesod/pull/1503)
|
||||
|
||||
## 1.6.4
|
||||
|
||||
* Add `addContentDispositionFileName` [#1504](https://github.com/yesodweb/yesod/pull/1504)
|
||||
|
||||
## 1.6.3
|
||||
|
||||
* Add missing export for `SubHandlerFor`
|
||||
|
||||
## 1.6.2
|
||||
|
||||
* Derive a `Show` instance for `ResourceTree` and `FlatResource` [#1492](https://github.com/yesodweb/yesod/pull/1492)
|
||||
* Some third party packages, like `yesod-routes-flow` derive their own `Show` instance, and this will break those packages.
|
||||
|
||||
## 1.6.1
|
||||
|
||||
* Add a `Semigroup LiteApp` instance, and explicitly define `(<>)` in the
|
||||
already existing `Semigroup` instances for `WidgetFor`, `Head`, `Body`,
|
||||
`GWData`, and `UniqueList`.
|
||||
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to conduit 1.3.0
|
||||
* Switch to `MonadUnliftIO`
|
||||
* Drop `mwc-random` and `blaze-builder` dependencies
|
||||
* Strictify some internal data structures
|
||||
* Add `CI` wrapper to first field in `Header` data constructor
|
||||
[#1418](https://github.com/yesodweb/yesod/issues/1418)
|
||||
* Internal only change, users of stable API are unaffected: `WidgetT`
|
||||
holds its data in an `IORef` so that it is isomorphic to `ReaderT`,
|
||||
avoiding state-loss issues..
|
||||
* Overhaul of `HandlerT`/`WidgetT` to no longer be transformers.
|
||||
* Fix Haddock comment & simplify implementation for `contentTypeTypes` [#1476](https://github.com/yesodweb/yesod/issues/1476)
|
||||
|
||||
## 1.4.37.3
|
||||
|
||||
* Improve error message when request body is too large [#1477](https://github.com/yesodweb/yesod/pull/1477)
|
||||
|
||||
## 1.4.37.2
|
||||
|
||||
* Improve error messages for the CSRF checking functions [#1455](https://github.com/yesodweb/yesod/issues/1455)
|
||||
|
||||
## 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)
|
||||
|
||||
@ -18,7 +18,7 @@ module Yesod.Core
|
||||
, Approot (..)
|
||||
, FileUpload (..)
|
||||
, ErrorResponse (..)
|
||||
-- * Utilities
|
||||
-- * Utitlities
|
||||
, maybeAuthorized
|
||||
, widgetToPageContent
|
||||
-- * Defaults
|
||||
@ -31,6 +31,7 @@ module Yesod.Core
|
||||
-- * Logging
|
||||
, defaultMakeLogger
|
||||
, defaultMessageLoggerSource
|
||||
, defaultShouldLog
|
||||
, defaultShouldLogIO
|
||||
, formatLogMessage
|
||||
, LogLevel (..)
|
||||
@ -66,9 +67,11 @@ module Yesod.Core
|
||||
-- * JS loaders
|
||||
, ScriptLoadPosition (..)
|
||||
, BottomOfHeadAsync
|
||||
-- * Generalizing type classes
|
||||
-- * Subsites
|
||||
, MonadHandler (..)
|
||||
, MonadWidget (..)
|
||||
, getRouteToParent
|
||||
, defaultLayoutSub
|
||||
-- * Approot
|
||||
, guessApproot
|
||||
, guessApprootOr
|
||||
@ -92,7 +95,8 @@ module Yesod.Core
|
||||
, module Text.Blaze.Html
|
||||
, MonadTrans (..)
|
||||
, MonadIO (..)
|
||||
, MonadUnliftIO (..)
|
||||
, MonadBase (..)
|
||||
, MonadBaseControl
|
||||
, MonadResource (..)
|
||||
, MonadLogger
|
||||
-- * Commonly referenced functions/datatypes
|
||||
@ -139,7 +143,9 @@ import qualified Yesod.Core.Internal.Run
|
||||
import qualified Paths_yesod_core
|
||||
import Data.Version (showVersion)
|
||||
import Yesod.Routes.Class
|
||||
import UnliftIO (MonadIO (..), MonadUnliftIO (..))
|
||||
import Control.Monad.IO.Class (MonadIO (..))
|
||||
import Control.Monad.Base (MonadBase (..))
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
|
||||
import Control.Monad.Trans.Resource (MonadResource (..))
|
||||
import Yesod.Core.Internal.LiteApp
|
||||
@ -179,6 +185,14 @@ maybeAuthorized r isWrite = do
|
||||
x <- isAuthorized r isWrite
|
||||
return $ if x == Authorized then Just r else Nothing
|
||||
|
||||
getRouteToParent :: Monad m => HandlerT child (HandlerT parent m) (Route child -> Route parent)
|
||||
getRouteToParent = HandlerT $ return . handlerToParent
|
||||
|
||||
defaultLayoutSub :: Yesod parent
|
||||
=> WidgetT child IO ()
|
||||
-> HandlerT child (HandlerT parent IO) Html
|
||||
defaultLayoutSub cwidget = widgetToParentWidget cwidget >>= lift . defaultLayout
|
||||
|
||||
showIntegral :: Integral a => a -> String
|
||||
showIntegral x = show (fromIntegral x :: Integer)
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Core.Class.Breadcrumbs where
|
||||
|
||||
import Yesod.Core.Handler
|
||||
@ -12,11 +11,11 @@ import Data.Text (Text)
|
||||
class YesodBreadcrumbs site where
|
||||
-- | Returns the title and the parent resource, if available. If you return
|
||||
-- a 'Nothing', then this is considered a top-level page.
|
||||
breadcrumb :: Route site -> HandlerFor site (Text , Maybe (Route site))
|
||||
breadcrumb :: Route site -> HandlerT site IO (Text , Maybe (Route site))
|
||||
|
||||
-- | Gets the title of the current page and the hierarchy of parent pages,
|
||||
-- along with their respective titles.
|
||||
breadcrumbs :: (YesodBreadcrumbs site, Show (Route site), Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)])
|
||||
breadcrumbs :: YesodBreadcrumbs site => HandlerT site IO (Text, [(Route site, Text)])
|
||||
breadcrumbs = do
|
||||
x <- getCurrentRoute
|
||||
case x of
|
||||
@ -27,8 +26,6 @@ breadcrumbs = do
|
||||
return (title, z)
|
||||
where
|
||||
go back Nothing = return back
|
||||
go back (Just this)
|
||||
| this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this
|
||||
| otherwise = do
|
||||
(title, next) <- breadcrumb this
|
||||
go ((this, title) : back) next
|
||||
go back (Just this) = do
|
||||
(title, next) <- breadcrumb this
|
||||
go ((this, title) : back) next
|
||||
42
yesod-core/Yesod/Core/Class/Dispatch.hs
Normal file
42
yesod-core/Yesod/Core/Class/Dispatch.hs
Normal file
@ -0,0 +1,42 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Core.Class.Dispatch where
|
||||
|
||||
import Yesod.Routes.Class
|
||||
import qualified Network.Wai as W
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Content
|
||||
import Yesod.Core.Handler (stripHandlerT)
|
||||
import Yesod.Core.Class.Yesod
|
||||
import Yesod.Core.Class.Handler
|
||||
|
||||
-- | This class is automatically instantiated when you use the template haskell
|
||||
-- mkYesod function. You should never need to deal with it directly.
|
||||
class Yesod site => YesodDispatch site where
|
||||
yesodDispatch :: YesodRunnerEnv site -> W.Application
|
||||
|
||||
class YesodSubDispatch sub m where
|
||||
yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m
|
||||
-> W.Application
|
||||
|
||||
instance YesodSubDispatch WaiSubsite master where
|
||||
yesodSubDispatch YesodSubRunnerEnv {..} = app
|
||||
where
|
||||
WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
|
||||
|
||||
-- | A helper function for creating YesodSubDispatch instances, used by the
|
||||
-- internal generated code. This function has been exported since 1.4.11.
|
||||
-- It promotes a subsite handler to a wai application.
|
||||
subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained.
|
||||
=> HandlerT child (HandlerT parent m) TypedContent
|
||||
-> YesodSubRunnerEnv child parent (HandlerT parent m)
|
||||
-> Maybe (Route child)
|
||||
-> W.Application
|
||||
subHelper handlert YesodSubRunnerEnv {..} route =
|
||||
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)
|
||||
where
|
||||
base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route
|
||||
100
yesod-core/Yesod/Core/Class/Handler.hs
Normal file
100
yesod-core/Yesod/Core/Class/Handler.hs
Normal file
@ -0,0 +1,100 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Yesod.Core.Class.Handler
|
||||
( MonadHandler (..)
|
||||
, MonadWidget (..)
|
||||
) where
|
||||
|
||||
import Yesod.Core.Types
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Data.Monoid (Monoid, mempty)
|
||||
#endif
|
||||
import Data.Conduit.Internal (Pipe, ConduitM)
|
||||
|
||||
import Control.Monad.Trans.Identity ( IdentityT)
|
||||
import Control.Monad.Trans.List ( ListT )
|
||||
import Control.Monad.Trans.Maybe ( MaybeT )
|
||||
import Control.Monad.Trans.Error ( ErrorT, Error)
|
||||
#if MIN_VERSION_transformers(0,4,0)
|
||||
import Control.Monad.Trans.Except ( ExceptT )
|
||||
#endif
|
||||
import Control.Monad.Trans.Reader ( ReaderT )
|
||||
import Control.Monad.Trans.State ( StateT )
|
||||
import Control.Monad.Trans.Writer ( WriterT )
|
||||
import Control.Monad.Trans.RWS ( RWST )
|
||||
import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )
|
||||
import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )
|
||||
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
|
||||
|
||||
class MonadResource m => MonadHandler m where
|
||||
type HandlerSite m
|
||||
liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a
|
||||
|
||||
replaceToParent :: HandlerData site route -> HandlerData site ()
|
||||
replaceToParent hd = hd { handlerToParent = const () }
|
||||
|
||||
instance MonadResourceBase m => MonadHandler (HandlerT site m) where
|
||||
type HandlerSite (HandlerT site m) = site
|
||||
liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent
|
||||
{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-}
|
||||
|
||||
instance MonadResourceBase m => MonadHandler (WidgetT site m) where
|
||||
type HandlerSite (WidgetT site m) = site
|
||||
liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent
|
||||
{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-}
|
||||
|
||||
#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
|
||||
#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
|
||||
GO(IdentityT)
|
||||
GO(ListT)
|
||||
GO(MaybeT)
|
||||
GOX(Error e, ErrorT e)
|
||||
#if MIN_VERSION_transformers(0,4,0)
|
||||
GO(ExceptT e)
|
||||
#endif
|
||||
GO(ReaderT r)
|
||||
GO(StateT s)
|
||||
GOX(Monoid w, WriterT w)
|
||||
GOX(Monoid w, RWST r w s)
|
||||
GOX(Monoid w, Strict.RWST r w s)
|
||||
GO(Strict.StateT s)
|
||||
GOX(Monoid w, Strict.WriterT w)
|
||||
GO(Pipe l i o u)
|
||||
GO(ConduitM i o)
|
||||
#undef GO
|
||||
#undef GOX
|
||||
|
||||
class MonadHandler m => MonadWidget m where
|
||||
liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
|
||||
instance MonadResourceBase m => MonadWidget (WidgetT site m) where
|
||||
liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent
|
||||
|
||||
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
|
||||
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
|
||||
GO(IdentityT)
|
||||
GO(ListT)
|
||||
GO(MaybeT)
|
||||
GOX(Error e, ErrorT e)
|
||||
#if MIN_VERSION_transformers(0,4,0)
|
||||
GO(ExceptT e)
|
||||
#endif
|
||||
GO(ReaderT r)
|
||||
GO(StateT s)
|
||||
GOX(Monoid w, WriterT w)
|
||||
GOX(Monoid w, RWST r w s)
|
||||
GOX(Monoid w, Strict.RWST r w s)
|
||||
GO(Strict.StateT s)
|
||||
GOX(Monoid w, Strict.WriterT w)
|
||||
GO(Pipe l i o u)
|
||||
GO(ConduitM i o)
|
||||
#undef GO
|
||||
#undef GOX
|
||||
@ -1,9 +1,8 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Core.Class.Yesod where
|
||||
|
||||
import Yesod.Core.Content
|
||||
@ -11,10 +10,14 @@ import Yesod.Core.Handler
|
||||
|
||||
import Yesod.Routes.Class
|
||||
|
||||
import Data.ByteString.Builder (Builder)
|
||||
import Data.Text.Encoding (encodeUtf8Builder)
|
||||
import Blaze.ByteString.Builder (Builder, toByteString)
|
||||
import Blaze.ByteString.Builder.ByteString (copyByteString)
|
||||
import Blaze.ByteString.Builder.Char.Utf8 (fromText, fromChar)
|
||||
import Control.Arrow ((***), second)
|
||||
import Control.Exception (bracket)
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad (forM, when, void)
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther),
|
||||
@ -25,7 +28,6 @@ import qualified Data.ByteString.Lazy as L
|
||||
import Data.Aeson (object, (.=))
|
||||
import Data.List (foldl', nub)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Monoid
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@ -35,8 +37,9 @@ import Data.Text.Lazy.Builder (toLazyText)
|
||||
import Data.Text.Lazy.Encoding (encodeUtf8)
|
||||
import Data.Word (Word64)
|
||||
import Language.Haskell.TH.Syntax (Loc (..))
|
||||
import Network.HTTP.Types (encodePath)
|
||||
import Network.HTTP.Types (encodePath, renderQueryText)
|
||||
import qualified Network.Wai as W
|
||||
import Data.Default (def)
|
||||
import Network.Wai.Parse (lbsBackEnd,
|
||||
tempFileBackEnd)
|
||||
import Network.Wai.Logger (ZonedDate, clockDateCacher)
|
||||
@ -49,15 +52,13 @@ import Text.Hamlet
|
||||
import Text.Julius
|
||||
import qualified Web.ClientSession as CS
|
||||
import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax,
|
||||
sameSiteStrict, SameSiteOption, defaultSetCookie)
|
||||
sameSiteStrict, SameSiteOption)
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Internal.Session
|
||||
import Yesod.Core.Widget
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
import qualified Network.Wai.Request
|
||||
import Data.IORef
|
||||
import UnliftIO (SomeException, catch, MonadUnliftIO)
|
||||
|
||||
-- | Define settings for a Yesod applications. All methods have intelligent
|
||||
-- defaults, and therefore no implementation is required.
|
||||
@ -65,33 +66,27 @@ class RenderRoute site => Yesod site where
|
||||
-- | An absolute URL to the root of the application. Do not include
|
||||
-- trailing slash.
|
||||
--
|
||||
-- Default value: 'guessApproot'. If you know your application root
|
||||
-- statically, it will be more efficient and more reliable to instead use
|
||||
-- 'ApprootStatic' or 'ApprootMaster'. If you do not need full absolute
|
||||
-- URLs, you can use 'ApprootRelative' instead.
|
||||
-- Default value: 'ApprootRelative'. This is valid under the following
|
||||
-- conditions:
|
||||
--
|
||||
-- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'.
|
||||
-- * Your application is served from the root of the domain.
|
||||
--
|
||||
-- * You do not use any features that require absolute URLs, such as Atom
|
||||
-- feeds and XML sitemaps.
|
||||
--
|
||||
-- If this is not true, you should override with a different
|
||||
-- implementation.
|
||||
approot :: Approot site
|
||||
approot = guessApproot
|
||||
|
||||
-- | @since 1.6.24.0
|
||||
-- allows the user to specify how exceptions are cought.
|
||||
-- by default all async exceptions are thrown and synchronous
|
||||
-- exceptions render a 500 page.
|
||||
-- To catch all exceptions (even async) to render a 500 page,
|
||||
-- set this to 'UnliftIO.Exception.catchSyncOrAsync'. Beware
|
||||
-- this may have negative effects with functions like 'timeout'.
|
||||
catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a
|
||||
catchHandlerExceptions _ = catch
|
||||
approot = ApprootRelative
|
||||
|
||||
-- | Output error response pages.
|
||||
--
|
||||
-- Default value: 'defaultErrorHandler'.
|
||||
errorHandler :: ErrorResponse -> HandlerFor site TypedContent
|
||||
errorHandler :: ErrorResponse -> HandlerT site IO TypedContent
|
||||
errorHandler = defaultErrorHandler
|
||||
|
||||
-- | Applies some form of layout to the contents of a page.
|
||||
defaultLayout :: WidgetFor site () -> HandlerFor site Html
|
||||
defaultLayout :: WidgetT site IO () -> HandlerT site IO Html
|
||||
defaultLayout w = do
|
||||
p <- widgetToPageContent w
|
||||
msgs <- getMessages
|
||||
@ -101,8 +96,6 @@ class RenderRoute site => Yesod site where
|
||||
<html>
|
||||
<head>
|
||||
<title>#{pageTitle p}
|
||||
$maybe description <- pageDescription p
|
||||
<meta name="description" content="#{description}">
|
||||
^{pageHead p}
|
||||
<body>
|
||||
$forall (status, msg) <- msgs
|
||||
@ -110,19 +103,33 @@ class RenderRoute site => Yesod site where
|
||||
^{pageBody p}
|
||||
|]
|
||||
|
||||
-- | Override the rendering function for a particular URL. One use case for
|
||||
-- this is to offload static hosting to a different domain name to avoid
|
||||
-- sending cookies.
|
||||
urlRenderOverride :: site -> Route site -> Maybe Builder
|
||||
urlRenderOverride _ _ = Nothing
|
||||
|
||||
-- | Override the rendering function for a particular URL and query string
|
||||
-- parameters. One use case for this is to offload static hosting to a
|
||||
-- different domain name to avoid sending cookies.
|
||||
--
|
||||
--
|
||||
-- For backward compatibility default implementation is in terms of
|
||||
-- 'urlRenderOverride', probably ineffective
|
||||
--
|
||||
--
|
||||
-- Since 1.4.23
|
||||
urlParamRenderOverride :: site
|
||||
-> Route site
|
||||
-> [(T.Text, T.Text)] -- ^ query string
|
||||
-> Maybe Builder
|
||||
urlParamRenderOverride _ _ _ = Nothing
|
||||
urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route
|
||||
where
|
||||
addParams [] routeBldr = routeBldr
|
||||
addParams nonEmptyParams routeBldr =
|
||||
let routeBS = toByteString routeBldr
|
||||
qsSeparator = fromChar $ if S8.elem '?' routeBS then '&' else '?'
|
||||
valueToMaybe t = if t == "" then Nothing else Just t
|
||||
queryText = map (id *** valueToMaybe) nonEmptyParams
|
||||
in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText
|
||||
|
||||
-- | Determine if a request is authorized or not.
|
||||
--
|
||||
@ -131,7 +138,7 @@ class RenderRoute site => Yesod site where
|
||||
-- If authentication is required, return 'AuthenticationRequired'.
|
||||
isAuthorized :: Route site
|
||||
-> Bool -- ^ is this a write request?
|
||||
-> HandlerFor site AuthResult
|
||||
-> HandlerT site IO AuthResult
|
||||
isAuthorized _ _ = return Authorized
|
||||
|
||||
-- | Determines whether the current request is a write request. By default,
|
||||
@ -141,7 +148,7 @@ class RenderRoute site => Yesod site where
|
||||
--
|
||||
-- This function is used to determine if a request is authorized; see
|
||||
-- 'isAuthorized'.
|
||||
isWriteRequest :: Route site -> HandlerFor site Bool
|
||||
isWriteRequest :: Route site -> HandlerT site IO Bool
|
||||
isWriteRequest _ = do
|
||||
wai <- waiRequest
|
||||
return $ W.requestMethod wai `notElem`
|
||||
@ -184,7 +191,7 @@ class RenderRoute site => Yesod site where
|
||||
-> [(T.Text, T.Text)] -- ^ query string
|
||||
-> Builder
|
||||
joinPath _ ar pieces' qs' =
|
||||
encodeUtf8Builder ar `mappend` encodePath pieces qs
|
||||
fromText ar `mappend` encodePath pieces qs
|
||||
where
|
||||
pieces = if null pieces' then [""] else map addDash pieces'
|
||||
qs = map (TE.encodeUtf8 *** go) qs'
|
||||
@ -207,11 +214,10 @@ class RenderRoute site => Yesod site where
|
||||
addStaticContent :: Text -- ^ filename extension
|
||||
-> Text -- ^ mime-type
|
||||
-> L.ByteString -- ^ content
|
||||
-> HandlerFor site (Maybe (Either Text (Route site, [(Text, Text)])))
|
||||
-> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
|
||||
addStaticContent _ _ _ = return Nothing
|
||||
|
||||
-- | Maximum allowed length of the request body, in bytes.
|
||||
-- This method may be ignored if 'maximumContentLengthIO' is overridden.
|
||||
--
|
||||
-- If @Nothing@, no maximum is applied.
|
||||
--
|
||||
@ -219,18 +225,6 @@ class RenderRoute site => Yesod site where
|
||||
maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64
|
||||
maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes
|
||||
|
||||
-- | Maximum allowed length of the request body, in bytes. This is similar
|
||||
-- to 'maximumContentLength', but the result lives in @IO@. This allows
|
||||
-- you to dynamically change the maximum file size based on some external
|
||||
-- source like a database or an @IORef@.
|
||||
--
|
||||
-- The default implementation uses 'maximumContentLength'. Future version of yesod will
|
||||
-- remove 'maximumContentLength' and use this method exclusively.
|
||||
--
|
||||
-- @since 1.6.13
|
||||
maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)
|
||||
maximumContentLengthIO a b = pure $ maximumContentLength a b
|
||||
|
||||
-- | Creates a @Logger@ to use for log messages.
|
||||
--
|
||||
-- Note that a common technique (endorsed by the scaffolding) is to create
|
||||
@ -260,21 +254,6 @@ class RenderRoute site => Yesod site where
|
||||
jsLoader :: site -> ScriptLoadPosition site
|
||||
jsLoader _ = BottomOfBody
|
||||
|
||||
-- | Default attributes to put on the JavaScript <script> tag
|
||||
-- generated for julius files
|
||||
jsAttributes :: site -> [(Text, Text)]
|
||||
jsAttributes _ = []
|
||||
|
||||
-- | Same as @jsAttributes@ but allows you to run arbitrary Handler code
|
||||
--
|
||||
-- This is useful if you need to add a randomised nonce value to the script
|
||||
-- tag generated by @widgetFile@. If this function is overridden then
|
||||
-- @jsAttributes@ is ignored.
|
||||
--
|
||||
-- @since 1.6.16
|
||||
jsAttributesHandler :: HandlerFor site [(Text, Text)]
|
||||
jsAttributesHandler = jsAttributes <$> getYesod
|
||||
|
||||
-- | Create a session backend. Returning 'Nothing' disables
|
||||
-- sessions. If you'd like to change the way that the session
|
||||
-- cookies are created, take a look at
|
||||
@ -296,11 +275,22 @@ class RenderRoute site => Yesod site where
|
||||
|
||||
-- | Should we log the given log source/level combination.
|
||||
--
|
||||
-- Default: the 'defaultShouldLogIO' function.
|
||||
-- Default: the 'defaultShouldLog' function.
|
||||
shouldLog :: site -> LogSource -> LogLevel -> Bool
|
||||
shouldLog _ = defaultShouldLog
|
||||
|
||||
-- | Should we log the given log source/level combination.
|
||||
--
|
||||
-- Note that this is almost identical to @shouldLog@, except the result
|
||||
-- lives in @IO@. This allows you to dynamically alter the logging level of
|
||||
-- your application by having this result depend on, e.g., an @IORef@.
|
||||
--
|
||||
-- The default implementation simply uses @shouldLog@. Future versions of
|
||||
-- Yesod will remove @shouldLog@ and use this method exclusively.
|
||||
--
|
||||
-- Since 1.2.4
|
||||
shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool
|
||||
shouldLogIO _ = defaultShouldLogIO
|
||||
shouldLogIO a b c = return (shouldLog a b c)
|
||||
|
||||
-- | A Yesod middleware, which will wrap every handler function. This
|
||||
-- allows you to run code before and after a normal handler.
|
||||
@ -308,7 +298,7 @@ class RenderRoute site => Yesod site where
|
||||
-- Default: the 'defaultYesodMiddleware' function.
|
||||
--
|
||||
-- Since: 1.1.6
|
||||
yesodMiddleware :: ToTypedContent res => HandlerFor site res -> HandlerFor site res
|
||||
yesodMiddleware :: ToTypedContent res => HandlerT site IO res -> HandlerT site IO res
|
||||
yesodMiddleware = defaultYesodMiddleware
|
||||
|
||||
-- | How to allocate an @InternalState@ for each request.
|
||||
@ -324,19 +314,7 @@ class RenderRoute site => Yesod site where
|
||||
yesodWithInternalState :: site -> Maybe (Route site) -> (InternalState -> IO a) -> IO a
|
||||
yesodWithInternalState _ _ = bracket createInternalState closeInternalState
|
||||
{-# INLINE yesodWithInternalState #-}
|
||||
|
||||
-- | Convert a title and HTML snippet into a 'Widget'. Used
|
||||
-- primarily for wrapping up error messages for better display.
|
||||
--
|
||||
-- @since 1.4.30
|
||||
defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site ()
|
||||
defaultMessageWidget title body = do
|
||||
setTitle title
|
||||
toWidget
|
||||
[hamlet|
|
||||
<h1>#{title}
|
||||
^{body}
|
||||
|]
|
||||
{-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-}
|
||||
|
||||
-- | Default implementation of 'makeLogger'. Sends to stdout and
|
||||
-- automatically flushes on each write.
|
||||
@ -373,18 +351,23 @@ defaultMessageLoggerSource ckLoggable logger loc source level msg = do
|
||||
-- above 'LevelInfo'.
|
||||
--
|
||||
-- Since 1.4.10
|
||||
defaultShouldLog :: LogSource -> LogLevel -> Bool
|
||||
defaultShouldLog _ level = level >= LevelInfo
|
||||
|
||||
-- | A default implementation of 'shouldLogIO' that can be used with
|
||||
-- 'defaultMessageLoggerSource'. Just uses 'defaultShouldLog'.
|
||||
--
|
||||
-- Since 1.4.10
|
||||
defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool
|
||||
defaultShouldLogIO _ level = return $ level >= LevelInfo
|
||||
defaultShouldLogIO a b = return $ defaultShouldLog a b
|
||||
|
||||
-- | Default implementation of 'yesodMiddleware'. Adds the response header
|
||||
-- \"Vary: Accept, Accept-Language\", \"X-XSS-Protection: 1; mode=block\", and
|
||||
-- performs authorization checks.
|
||||
-- \"Vary: Accept, Accept-Language\" and performs authorization checks.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
|
||||
defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
|
||||
defaultYesodMiddleware handler = do
|
||||
addHeader "Vary" "Accept, Accept-Language"
|
||||
addHeader "X-XSS-Protection" "1; mode=block"
|
||||
authorizationCheck
|
||||
handler
|
||||
|
||||
@ -441,9 +424,10 @@ sameSiteSession s = (fmap . fmap) secureSessionCookies
|
||||
-- headers are ignored over HTTP.
|
||||
--
|
||||
-- Since 1.4.7
|
||||
sslOnlyMiddleware :: Int -- ^ minutes
|
||||
-> HandlerFor site res
|
||||
-> HandlerFor site res
|
||||
sslOnlyMiddleware :: Yesod site
|
||||
=> Int -- ^ minutes
|
||||
-> HandlerT site IO res
|
||||
-> HandlerT site IO res
|
||||
sslOnlyMiddleware timeout handler = do
|
||||
addHeader "Strict-Transport-Security"
|
||||
$ T.pack $ concat [ "max-age="
|
||||
@ -456,7 +440,7 @@ sslOnlyMiddleware timeout handler = do
|
||||
-- 'isWriteRequest'.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
authorizationCheck :: Yesod site => HandlerFor site ()
|
||||
authorizationCheck :: Yesod site => HandlerT site IO ()
|
||||
authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
|
||||
where
|
||||
checkUrl url = do
|
||||
@ -480,7 +464,7 @@ authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
|
||||
-- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
|
||||
--
|
||||
-- Since 1.4.14
|
||||
defaultCsrfCheckMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
|
||||
defaultCsrfCheckMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
|
||||
defaultCsrfCheckMiddleware handler =
|
||||
csrfCheckMiddleware
|
||||
handler
|
||||
@ -494,11 +478,12 @@ defaultCsrfCheckMiddleware handler =
|
||||
-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".
|
||||
--
|
||||
-- Since 1.4.14
|
||||
csrfCheckMiddleware :: HandlerFor site res
|
||||
-> HandlerFor site Bool -- ^ Whether or not to perform the CSRF check.
|
||||
csrfCheckMiddleware :: Yesod site
|
||||
=> HandlerT site IO res
|
||||
-> HandlerT site IO Bool -- ^ Whether or not to perform the CSRF check.
|
||||
-> CI S8.ByteString -- ^ The header name to lookup the CSRF token from.
|
||||
-> Text -- ^ The POST parameter name to lookup the CSRF token from.
|
||||
-> HandlerFor site res
|
||||
-> HandlerT site IO res
|
||||
csrfCheckMiddleware handler shouldCheckFn headerName paramName = do
|
||||
shouldCheck <- shouldCheckFn
|
||||
when shouldCheck (checkCsrfHeaderOrParam headerName paramName)
|
||||
@ -509,7 +494,7 @@ csrfCheckMiddleware handler shouldCheckFn headerName paramName = do
|
||||
-- The cookie's path is set to @/@, making it valid for your whole website.
|
||||
--
|
||||
-- Since 1.4.14
|
||||
defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res
|
||||
defaultCsrfSetCookieMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
|
||||
defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler
|
||||
|
||||
-- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'.
|
||||
@ -519,14 +504,14 @@ defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler
|
||||
-- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.
|
||||
--
|
||||
-- Since 1.4.14
|
||||
csrfSetCookieMiddleware :: HandlerFor site res -> SetCookie -> HandlerFor site res
|
||||
csrfSetCookieMiddleware :: Yesod site => HandlerT site IO res -> SetCookie -> HandlerT site IO res
|
||||
csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler
|
||||
|
||||
-- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'.
|
||||
--
|
||||
-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".
|
||||
--
|
||||
-- You can chain this middleware together with other middleware like so:
|
||||
-- You can add this chain this middleware together with other middleware like so:
|
||||
--
|
||||
-- @
|
||||
-- 'yesodMiddleware' = 'defaultYesodMiddleware' . 'defaultCsrfMiddleware'
|
||||
@ -539,29 +524,21 @@ csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handl
|
||||
-- @
|
||||
--
|
||||
-- Since 1.4.14
|
||||
defaultCsrfMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
|
||||
defaultCsrfMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
|
||||
defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware
|
||||
|
||||
-- | Convert a widget to a 'PageContent'.
|
||||
widgetToPageContent :: Yesod site
|
||||
=> WidgetFor site ()
|
||||
-> HandlerFor site (PageContent (Route site))
|
||||
widgetToPageContent :: (Eq (Route site), Yesod site)
|
||||
=> WidgetT site IO ()
|
||||
-> HandlerT site IO (PageContent (Route site))
|
||||
widgetToPageContent w = do
|
||||
jsAttrs <- jsAttributesHandler
|
||||
HandlerFor $ \hd -> do
|
||||
master <- unHandlerFor getYesod hd
|
||||
ref <- newIORef mempty
|
||||
unWidgetFor w WidgetData
|
||||
{ wdRef = ref
|
||||
, wdHandler = hd
|
||||
}
|
||||
GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref
|
||||
let title = maybe mempty unTitle mTitle
|
||||
description = unDescription <$> mDescription
|
||||
scripts = runUniqueList scripts'
|
||||
stylesheets = runUniqueList stylesheets'
|
||||
master <- getYesod
|
||||
hd <- HandlerT return
|
||||
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd
|
||||
let title = maybe mempty unTitle mTitle
|
||||
scripts = runUniqueList scripts'
|
||||
stylesheets = runUniqueList stylesheets'
|
||||
|
||||
flip unHandlerFor hd $ do
|
||||
render <- getUrlRenderParams
|
||||
let renderLoc x =
|
||||
case x of
|
||||
@ -593,7 +570,7 @@ widgetToPageContent w = do
|
||||
^{mkScriptTag s}
|
||||
$maybe j <- jscript
|
||||
$maybe s <- jsLoc
|
||||
<script src="#{s}" *{jsAttrs}>
|
||||
<script src="#{s}">
|
||||
$nothing
|
||||
<script>^{jelper j}
|
||||
|]
|
||||
@ -627,7 +604,7 @@ widgetToPageContent w = do
|
||||
^{regularScriptLoad}
|
||||
|]
|
||||
|
||||
return $ PageContent title description headAll $
|
||||
return $ PageContent title headAll $
|
||||
case jsLoader master of
|
||||
BottomOfBody -> bodyScript
|
||||
_ -> body
|
||||
@ -649,23 +626,29 @@ widgetToPageContent w = do
|
||||
runUniqueList (UniqueList x) = nub $ x []
|
||||
|
||||
-- | The default error handler for 'errorHandler'.
|
||||
defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent
|
||||
defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent
|
||||
defaultErrorHandler NotFound = selectRep $ do
|
||||
provideRep $ defaultLayout $ do
|
||||
r <- waiRequest
|
||||
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
|
||||
defaultMessageWidget "Not Found" [hamlet|<p>#{path'}|]
|
||||
setTitle "Not Found"
|
||||
toWidget [hamlet|
|
||||
<h1>Not Found
|
||||
<p>#{path'}
|
||||
|]
|
||||
provideRep $ return $ object ["message" .= ("Not Found" :: Text)]
|
||||
provideRep $ return ("Not Found" :: Text)
|
||||
|
||||
-- For API requests.
|
||||
-- For a user with a browser,
|
||||
-- if you specify an authRoute the user will be redirected there and
|
||||
-- this page will not be shown.
|
||||
defaultErrorHandler NotAuthenticated = selectRep $ do
|
||||
provideRep $ defaultLayout $ defaultMessageWidget
|
||||
"Not logged in"
|
||||
[hamlet|<p style="display:none;">Set the authRoute and the user will be redirected there.|]
|
||||
provideRep $ defaultLayout $ do
|
||||
setTitle "Not logged in"
|
||||
toWidget [hamlet|
|
||||
<h1>Not logged in
|
||||
<p style="display:none;">Set the authRoute and the user will be redirected there.
|
||||
|]
|
||||
|
||||
provideRep $ do
|
||||
-- 401 *MUST* include a WWW-Authenticate header
|
||||
@ -680,42 +663,45 @@ defaultErrorHandler NotAuthenticated = selectRep $ do
|
||||
let apair u = ["authentication_url" .= rend u]
|
||||
content = maybe [] apair (authRoute site)
|
||||
return $ object $ ("message" .= ("Not logged in"::Text)):content
|
||||
provideRep $ return ("Not logged in" :: Text)
|
||||
|
||||
defaultErrorHandler (PermissionDenied msg) = selectRep $ do
|
||||
provideRep $ defaultLayout $ defaultMessageWidget
|
||||
"Permission Denied"
|
||||
[hamlet|<p>#{msg}|]
|
||||
provideRep $ defaultLayout $ do
|
||||
setTitle "Permission Denied"
|
||||
toWidget [hamlet|
|
||||
<h1>Permission denied
|
||||
<p>#{msg}
|
||||
|]
|
||||
provideRep $
|
||||
return $ object ["message" .= ("Permission Denied. " <> msg)]
|
||||
provideRep $ return $ "Permission Denied. " <> msg
|
||||
|
||||
defaultErrorHandler (InvalidArgs ia) = selectRep $ do
|
||||
provideRep $ defaultLayout $ defaultMessageWidget
|
||||
"Invalid Arguments"
|
||||
[hamlet|
|
||||
provideRep $ defaultLayout $ do
|
||||
setTitle "Invalid Arguments"
|
||||
toWidget [hamlet|
|
||||
<h1>Invalid Arguments
|
||||
<ul>
|
||||
$forall msg <- ia
|
||||
<li>#{msg}
|
||||
|]
|
||||
provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]
|
||||
provideRep $ return ("Invalid Arguments: " <> T.intercalate " " ia)
|
||||
|
||||
defaultErrorHandler (InternalError e) = do
|
||||
$logErrorS "yesod-core" e
|
||||
selectRep $ do
|
||||
provideRep $ defaultLayout $ defaultMessageWidget
|
||||
"Internal Server Error"
|
||||
[hamlet|<pre>#{e}|]
|
||||
provideRep $ defaultLayout $ do
|
||||
setTitle "Internal Server Error"
|
||||
toWidget [hamlet|
|
||||
<h1>Internal Server Error
|
||||
<pre>#{e}
|
||||
|]
|
||||
provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]
|
||||
provideRep $ return $ "Internal Server Error: " <> e
|
||||
|
||||
defaultErrorHandler (BadMethod m) = selectRep $ do
|
||||
provideRep $ defaultLayout $ defaultMessageWidget
|
||||
"Method Not Supported"
|
||||
[hamlet|<p>Method <code>#{S8.unpack m}</code> not supported|]
|
||||
provideRep $ defaultLayout $ do
|
||||
setTitle"Bad Method"
|
||||
toWidget [hamlet|
|
||||
<h1>Method Not Supported
|
||||
<p>Method <code>#{S8.unpack m}</code> not supported
|
||||
|]
|
||||
provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
|
||||
provideRep $ return $ "Bad Method " <> TE.decodeUtf8With TEE.lenientDecode m
|
||||
|
||||
asyncHelper :: (url -> [x] -> Text)
|
||||
-> [Script url]
|
||||
@ -863,12 +849,6 @@ clientSessionBackend key getCachedDate =
|
||||
sbLoadSession = loadClientSession key getCachedDate "_SESSION"
|
||||
}
|
||||
|
||||
justSingleton :: a -> [Maybe a] -> a
|
||||
justSingleton d = just . catMaybes
|
||||
where
|
||||
just [s] = s
|
||||
just _ = d
|
||||
|
||||
loadClientSession :: CS.Key
|
||||
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
|
||||
-> S8.ByteString -- ^ session name
|
||||
@ -879,15 +859,15 @@ loadClientSession key getCachedDate sessionName req = load
|
||||
load = do
|
||||
date <- getCachedDate
|
||||
return (sess date, save date)
|
||||
sess date = justSingleton Map.empty $ do
|
||||
sess date = Map.unions $ do
|
||||
raw <- [v | (k, v) <- W.requestHeaders req, k == "Cookie"]
|
||||
val <- [v | (k, v) <- parseCookies raw, k == sessionName]
|
||||
let host = "" -- fixme, properly lock sessions to client address
|
||||
return $ decodeClientSession key date host val
|
||||
maybe [] return $ decodeClientSession key date host val
|
||||
save date sess' = do
|
||||
-- We should never cache the IV! Be careful!
|
||||
iv <- liftIO CS.randomIV
|
||||
return [AddCookie defaultSetCookie
|
||||
return [AddCookie def
|
||||
{ setCookieName = sessionName
|
||||
, setCookieValue = encodeClientSession key iv date host sess'
|
||||
, setCookiePath = Just "/"
|
||||
@ -4,6 +4,7 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Core.Content
|
||||
( -- * Content
|
||||
Content (..)
|
||||
@ -52,24 +53,30 @@ import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Text.Lazy (Text, pack)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8Builder)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8)
|
||||
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Data.Monoid (mempty)
|
||||
#endif
|
||||
import Text.Hamlet (Html)
|
||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
|
||||
import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput)
|
||||
import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.Trans.Resource (ResourceT)
|
||||
import Data.Conduit.Internal (ResumableSource (ResumableSource))
|
||||
import qualified Data.Conduit.Internal as CI
|
||||
|
||||
import qualified Data.Aeson as J
|
||||
#if MIN_VERSION_aeson(0, 7, 0)
|
||||
import Data.Aeson.Encode (encodeToTextBuilder)
|
||||
#else
|
||||
import Data.Aeson.Encode (fromValue)
|
||||
#endif
|
||||
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
|
||||
import Data.Text.Lazy.Builder (toLazyText)
|
||||
import Data.Void (Void, absurd)
|
||||
import Yesod.Core.Types
|
||||
import Text.Lucius (Css, renderCss)
|
||||
import Text.Julius (Javascript, unJavascript)
|
||||
import Data.Word8 (_semicolon, _slash)
|
||||
import Control.Arrow (second)
|
||||
|
||||
-- | Zero-length enumerator.
|
||||
emptyContent :: Content
|
||||
@ -91,27 +98,23 @@ instance ToContent Content where
|
||||
instance ToContent Builder where
|
||||
toContent = flip ContentBuilder Nothing
|
||||
instance ToContent B.ByteString where
|
||||
toContent bs = ContentBuilder (byteString bs) $ Just $ B.length bs
|
||||
toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs
|
||||
instance ToContent L.ByteString where
|
||||
toContent = flip ContentBuilder Nothing . lazyByteString
|
||||
toContent = flip ContentBuilder Nothing . fromLazyByteString
|
||||
instance ToContent T.Text where
|
||||
toContent = toContent . encodeUtf8Builder
|
||||
toContent = toContent . Blaze.fromText
|
||||
instance ToContent Text where
|
||||
toContent = toContent . foldMap encodeUtf8Builder . TL.toChunks
|
||||
toContent = toContent . Blaze.fromLazyText
|
||||
instance ToContent String where
|
||||
toContent = toContent . stringUtf8
|
||||
toContent = toContent . Blaze.fromString
|
||||
instance ToContent Html where
|
||||
toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
|
||||
instance ToContent () where
|
||||
toContent () = toContent B.empty
|
||||
instance ToContent Void where
|
||||
toContent = absurd
|
||||
instance ToContent (ContentType, Content) where
|
||||
toContent = snd
|
||||
instance ToContent TypedContent where
|
||||
toContent (TypedContent _ c) = c
|
||||
instance ToContent (JSONResponse a) where
|
||||
toContent (JSONResponse a) = toContent $ J.toEncoding a
|
||||
|
||||
instance ToContent Css where
|
||||
toContent = toContent . renderCss
|
||||
@ -119,12 +122,12 @@ instance ToContent Javascript where
|
||||
toContent = toContent . toLazyText . unJavascript
|
||||
|
||||
instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where
|
||||
toContent src = ContentSource $ CI.ConduitT (CI.mapOutput toFlushBuilder src >>=)
|
||||
toContent src = ContentSource $ CI.ConduitM (CI.mapOutput toFlushBuilder src >>=)
|
||||
|
||||
instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where
|
||||
instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
|
||||
toContent src = ContentSource $ mapOutput toFlushBuilder src
|
||||
instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where
|
||||
toContent (CI.SealedConduitT src) = toContent src
|
||||
instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where
|
||||
toContent (ResumableSource src _) = toContent src
|
||||
|
||||
-- | A class for all data which can be sent in a streaming response. Note that
|
||||
-- for textual data, instances must use UTF-8 encoding.
|
||||
@ -133,16 +136,16 @@ instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (Resourc
|
||||
class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder
|
||||
instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id
|
||||
instance ToFlushBuilder Builder where toFlushBuilder = Chunk
|
||||
instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap byteString
|
||||
instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . byteString
|
||||
instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap lazyByteString
|
||||
instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . lazyByteString
|
||||
instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap (foldMap encodeUtf8Builder . TL.toChunks)
|
||||
instance ToFlushBuilder Text where toFlushBuilder = Chunk . foldMap encodeUtf8Builder . TL.toChunks
|
||||
instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap encodeUtf8Builder
|
||||
instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . encodeUtf8Builder
|
||||
instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap stringUtf8
|
||||
instance ToFlushBuilder String where toFlushBuilder = Chunk . stringUtf8
|
||||
instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString
|
||||
instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString
|
||||
instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap fromLazyByteString
|
||||
instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . fromLazyByteString
|
||||
instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap Blaze.fromLazyText
|
||||
instance ToFlushBuilder Text where toFlushBuilder = Chunk . Blaze.fromLazyText
|
||||
instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap Blaze.fromText
|
||||
instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . Blaze.fromText
|
||||
instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap Blaze.fromString
|
||||
instance ToFlushBuilder String where toFlushBuilder = Chunk . Blaze.fromString
|
||||
instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder
|
||||
instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder
|
||||
|
||||
@ -165,8 +168,6 @@ deriving instance ToContent RepJson
|
||||
instance HasContentType RepPlain where
|
||||
getContentType _ = typePlain
|
||||
deriving instance ToContent RepPlain
|
||||
instance HasContentType (JSONResponse a) where
|
||||
getContentType _ = typeJson
|
||||
|
||||
instance HasContentType RepXml where
|
||||
getContentType _ = typeXml
|
||||
@ -226,13 +227,13 @@ typeOctet = "application/octet-stream"
|
||||
simpleContentType :: ContentType -> ContentType
|
||||
simpleContentType = fst . B.break (== _semicolon)
|
||||
|
||||
-- | Give just the media types as a pair.
|
||||
--
|
||||
-- Give just the media types as a pair.
|
||||
-- For example, \"text/html; charset=utf-8\" returns ("text", "html")
|
||||
contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString)
|
||||
contentTypeTypes = second tailEmpty . B.break (== _slash) . simpleContentType
|
||||
contentTypeTypes ct = (main, fst $ B.break (== _semicolon) (tailEmpty sub))
|
||||
where
|
||||
tailEmpty x = if B.null x then "" else B.tail x
|
||||
(main, sub) = B.break (== _slash) ct
|
||||
|
||||
instance HasContentType a => HasContentType (DontFullyEvaluate a) where
|
||||
getContentType = getContentType . liftM unDontFullyEvaluate
|
||||
@ -242,17 +243,26 @@ instance ToContent a => ToContent (DontFullyEvaluate a) where
|
||||
|
||||
instance ToContent J.Value where
|
||||
toContent = flip ContentBuilder Nothing
|
||||
. J.fromEncoding
|
||||
. J.toEncoding
|
||||
. Blaze.fromLazyText
|
||||
. toLazyText
|
||||
#if MIN_VERSION_aeson(0, 7, 0)
|
||||
. encodeToTextBuilder
|
||||
#else
|
||||
. fromValue
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_aeson(0, 11, 0)
|
||||
instance ToContent J.Encoding where
|
||||
toContent = flip ContentBuilder Nothing . J.fromEncoding
|
||||
#endif
|
||||
|
||||
instance HasContentType J.Value where
|
||||
getContentType _ = typeJson
|
||||
|
||||
#if MIN_VERSION_aeson(0, 11, 0)
|
||||
instance HasContentType J.Encoding where
|
||||
getContentType _ = typeJson
|
||||
#endif
|
||||
|
||||
instance HasContentType Html where
|
||||
getContentType _ = typeHtml
|
||||
@ -279,8 +289,6 @@ instance ToTypedContent TypedContent where
|
||||
toTypedContent = id
|
||||
instance ToTypedContent () where
|
||||
toTypedContent () = TypedContent typePlain (toContent ())
|
||||
instance ToTypedContent Void where
|
||||
toTypedContent = absurd
|
||||
instance ToTypedContent (ContentType, Content) where
|
||||
toTypedContent (ct, content) = TypedContent ct content
|
||||
instance ToTypedContent RepJson where
|
||||
@ -291,8 +299,10 @@ instance ToTypedContent RepXml where
|
||||
toTypedContent (RepXml c) = TypedContent typeXml c
|
||||
instance ToTypedContent J.Value where
|
||||
toTypedContent v = TypedContent typeJson (toContent v)
|
||||
#if MIN_VERSION_aeson(0, 11, 0)
|
||||
instance ToTypedContent J.Encoding where
|
||||
toTypedContent e = TypedContent typeJson (toContent e)
|
||||
#endif
|
||||
instance ToTypedContent Html where
|
||||
toTypedContent h = TypedContent typeHtml (toContent h)
|
||||
instance ToTypedContent T.Text where
|
||||
@ -301,8 +311,6 @@ instance ToTypedContent [Char] where
|
||||
toTypedContent = toTypedContent . pack
|
||||
instance ToTypedContent Text where
|
||||
toTypedContent t = TypedContent typePlain (toContent t)
|
||||
instance ToTypedContent (JSONResponse a) where
|
||||
toTypedContent c = TypedContent typeJson (toContent c)
|
||||
instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
|
||||
toTypedContent (DontFullyEvaluate a) =
|
||||
let TypedContent ct c = toTypedContent a
|
||||
@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Core.Dispatch
|
||||
( -- * Quasi-quoted routing
|
||||
parseRoutes
|
||||
@ -10,25 +11,12 @@ module Yesod.Core.Dispatch
|
||||
, parseRoutesFile
|
||||
, parseRoutesFileNoCheck
|
||||
, mkYesod
|
||||
, mkYesodOpts
|
||||
, mkYesodWith
|
||||
-- ** More fine-grained
|
||||
, mkYesodData
|
||||
, mkYesodDataOpts
|
||||
, mkYesodSubData
|
||||
, mkYesodSubDataOpts
|
||||
, mkYesodDispatch
|
||||
, mkYesodDispatchOpts
|
||||
, mkYesodSubDispatch
|
||||
-- *** Route generation options
|
||||
, RouteOpts
|
||||
, defaultOpts
|
||||
, setEqDerived
|
||||
, setShowDerived
|
||||
, setReadDerived
|
||||
-- *** Helpers
|
||||
, defaultGen
|
||||
, getGetMaxExpires
|
||||
-- ** Path pieces
|
||||
, PathPiece (..)
|
||||
, PathMultiPiece (..)
|
||||
@ -36,7 +24,6 @@ module Yesod.Core.Dispatch
|
||||
-- * Convert to WAI
|
||||
, toWaiApp
|
||||
, toWaiAppPlain
|
||||
, toWaiAppYre
|
||||
, warp
|
||||
, warpDebug
|
||||
, warpEnv
|
||||
@ -44,7 +31,7 @@ module Yesod.Core.Dispatch
|
||||
, defaultMiddlewaresNoLogging
|
||||
-- * WAI subsites
|
||||
, WaiSubsite (..)
|
||||
, WaiSubsiteWithAuth (..)
|
||||
, subHelper
|
||||
) where
|
||||
|
||||
import Prelude hiding (exp)
|
||||
@ -57,21 +44,21 @@ import qualified Network.Wai as W
|
||||
|
||||
import Data.ByteString.Lazy.Char8 ()
|
||||
|
||||
import Data.Bits ((.|.), finiteBitSize, shiftL)
|
||||
import Data.Text (Text)
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Data.Monoid (mappend)
|
||||
#endif
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Data.ByteString.Builder (byteString, toLazyByteString)
|
||||
import qualified Blaze.ByteString.Builder
|
||||
import Network.HTTP.Types (status301, status307)
|
||||
import Yesod.Routes.Parse
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Class.Yesod
|
||||
import Yesod.Core.Class.Dispatch
|
||||
import Yesod.Core.Internal.Run
|
||||
import Text.Read (readMaybe)
|
||||
import Safe (readMay)
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Entropy (getEntropy)
|
||||
import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
|
||||
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
|
||||
|
||||
@ -87,6 +74,7 @@ import Control.Monad.Logger
|
||||
import Control.Monad (when)
|
||||
import qualified Paths_yesod_core
|
||||
import Data.Version (showVersion)
|
||||
import qualified System.Random.MWC as MWC
|
||||
|
||||
-- | Convert the given argument into a WAI application, executable with any WAI
|
||||
-- handler. This function will provide no middlewares; if you want commonly
|
||||
@ -95,36 +83,16 @@ toWaiAppPlain :: YesodDispatch site => site -> IO W.Application
|
||||
toWaiAppPlain site = do
|
||||
logger <- makeLogger site
|
||||
sb <- makeSessionBackend site
|
||||
gen <- MWC.createSystemRandom
|
||||
getMaxExpires <- getGetMaxExpires
|
||||
return $ toWaiAppYre YesodRunnerEnv
|
||||
{ yreLogger = logger
|
||||
, yreSite = site
|
||||
, yreSessionBackend = sb
|
||||
, yreGen = defaultGen
|
||||
, yreGen = gen
|
||||
, yreGetMaxExpires = getMaxExpires
|
||||
}
|
||||
|
||||
-- | Generate a random number uniformly distributed in the full range
|
||||
-- of 'Int'.
|
||||
--
|
||||
-- Note: Before 1.6.20, this generates pseudo-random number in an
|
||||
-- unspecified range. The range size may not be a power of 2. Since
|
||||
-- 1.6.20, this uses a secure entropy source and generates in the full
|
||||
-- range of 'Int'.
|
||||
--
|
||||
-- @since 1.6.21.0
|
||||
defaultGen :: IO Int
|
||||
defaultGen = bsToInt <$> getEntropy bytes
|
||||
where
|
||||
bits = finiteBitSize (undefined :: Int)
|
||||
bytes = div (bits + 7) 8
|
||||
bsToInt = S.foldl' (\v i -> shiftL v 8 .|. fromIntegral i) 0
|
||||
|
||||
-- | Pure low level function to construct WAI application. Usefull
|
||||
-- when you need not standard way to run your app, or want to embed it
|
||||
-- inside another app.
|
||||
--
|
||||
-- @since 1.4.29
|
||||
toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application
|
||||
toWaiAppYre yre req =
|
||||
case cleanPath site $ W.pathInfo req of
|
||||
@ -138,7 +106,7 @@ toWaiAppYre yre req =
|
||||
sendRedirect y segments' env sendResponse =
|
||||
sendResponse $ W.responseLBS status
|
||||
[ ("Content-Type", "text/plain")
|
||||
, ("Location", BL.toStrict $ toLazyByteString dest')
|
||||
, ("Location", Blaze.ByteString.Builder.toByteString dest')
|
||||
] "Redirecting"
|
||||
where
|
||||
-- Ensure that non-GET requests get redirected correctly. See:
|
||||
@ -152,7 +120,7 @@ toWaiAppYre yre req =
|
||||
if S.null (W.rawQueryString env)
|
||||
then dest
|
||||
else dest `mappend`
|
||||
byteString (W.rawQueryString env)
|
||||
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)
|
||||
|
||||
-- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This
|
||||
-- set may change with future releases, but currently covers:
|
||||
@ -174,12 +142,13 @@ toWaiApp site = do
|
||||
toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
|
||||
toWaiAppLogger logger site = do
|
||||
sb <- makeSessionBackend site
|
||||
gen <- MWC.createSystemRandom
|
||||
getMaxExpires <- getGetMaxExpires
|
||||
let yre = YesodRunnerEnv
|
||||
{ yreLogger = logger
|
||||
, yreSite = site
|
||||
, yreSessionBackend = sb
|
||||
, yreGen = defaultGen
|
||||
, yreGen = gen
|
||||
, yreGetMaxExpires = getMaxExpires
|
||||
}
|
||||
messageLoggerSource
|
||||
@ -197,16 +166,6 @@ toWaiAppLogger logger site = do
|
||||
-- middlewares. This set may change at any point without a breaking version
|
||||
-- number. Currently, it includes:
|
||||
--
|
||||
-- * Logging
|
||||
--
|
||||
-- * GZIP compression
|
||||
--
|
||||
-- * Automatic HEAD method handling
|
||||
--
|
||||
-- * Request method override with the _method query string parameter
|
||||
--
|
||||
-- * Accept header override with the _accept query string parameter
|
||||
--
|
||||
-- If you need more fine-grained control of middlewares, please use 'toWaiApp'
|
||||
-- directly.
|
||||
--
|
||||
@ -274,14 +233,10 @@ warpEnv site = do
|
||||
case lookup "PORT" env of
|
||||
Nothing -> error "warpEnv: no PORT environment variable found"
|
||||
Just portS ->
|
||||
case readMaybe portS of
|
||||
case readMay portS of
|
||||
Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS
|
||||
Just port -> warp port site
|
||||
|
||||
-- | Default constructor for 'yreGetMaxExpires' field. Low level
|
||||
-- function for simple manual construction of 'YesodRunnerEnv'.
|
||||
--
|
||||
-- @since 1.4.29
|
||||
getGetMaxExpires :: IO (IO Text)
|
||||
getGetMaxExpires = mkAutoUpdate defaultUpdateSettings
|
||||
{ updateAction = getCurrentMaxExpiresRFC1123
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,8 +1,8 @@
|
||||
{-# LANGUAGE TypeFamilies, PatternGuards, CPP #-}
|
||||
module Yesod.Core.Internal.LiteApp where
|
||||
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup (Semigroup(..))
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Data.Monoid
|
||||
#endif
|
||||
import Yesod.Routes.Class
|
||||
import Yesod.Core.Class.Yesod
|
||||
@ -42,17 +42,12 @@ instance RenderRoute LiteApp where
|
||||
instance ParseRoute LiteApp where
|
||||
parseRoute (x, _) = Just $ LiteAppRoute x
|
||||
|
||||
instance Semigroup LiteApp where
|
||||
LiteApp x <> LiteApp y = LiteApp $ \m ps -> x m ps <|> y m ps
|
||||
|
||||
instance Monoid LiteApp where
|
||||
mempty = LiteApp $ \_ _ -> Nothing
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
mappend = (<>)
|
||||
#endif
|
||||
mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps
|
||||
|
||||
type LiteHandler = HandlerFor LiteApp
|
||||
type LiteWidget = WidgetFor LiteApp
|
||||
type LiteHandler = HandlerT LiteApp IO
|
||||
type LiteWidget = WidgetT LiteApp IO
|
||||
|
||||
liteApp :: Writer LiteApp () -> LiteApp
|
||||
liteApp = execWriter
|
||||
@ -25,7 +25,6 @@ import qualified Network.Wai as W
|
||||
import Web.Cookie (parseCookiesText)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy.Char8 as LS8
|
||||
import Data.Text (Text, pack)
|
||||
import Network.HTTP.Types (queryToQueryText, Status (Status))
|
||||
import Data.Maybe (fromMaybe, catMaybes)
|
||||
@ -34,13 +33,18 @@ import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8With, decodeUtf8)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Conduit
|
||||
import Data.Conduit
|
||||
import Data.Conduit.List (sourceList)
|
||||
import Data.Conduit.Binary (sourceFile, sinkFile)
|
||||
import Data.Word (Word8, Word64)
|
||||
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Monad ((<=<), liftM)
|
||||
import Yesod.Core.Types
|
||||
import qualified Data.Map as Map
|
||||
import Data.IORef
|
||||
import qualified System.Random.MWC as MWC
|
||||
import Control.Monad.Primitive (PrimMonad, PrimState)
|
||||
import qualified Data.Vector.Storable as V
|
||||
import Data.ByteString.Internal (ByteString (PS))
|
||||
import qualified Data.Word8 as Word8
|
||||
@ -56,29 +60,23 @@ limitRequestBody maxLen req = do
|
||||
let len = fromIntegral $ S8.length bs
|
||||
remaining' = remaining - len
|
||||
if remaining < len
|
||||
then throwIO $ HCWai $ tooLargeResponse maxLen len
|
||||
then throwIO $ HCWai tooLargeResponse
|
||||
else do
|
||||
writeIORef ref remaining'
|
||||
return bs
|
||||
}
|
||||
|
||||
tooLargeResponse :: Word64 -> Word64 -> W.Response
|
||||
tooLargeResponse maxLen bodyLen = W.responseLBS
|
||||
tooLargeResponse :: W.Response
|
||||
tooLargeResponse = W.responseLBS
|
||||
(Status 413 "Too Large")
|
||||
[("Content-Type", "text/plain")]
|
||||
(L.concat
|
||||
[ "Request body too large to be processed. The maximum size is "
|
||||
, (LS8.pack (show maxLen))
|
||||
, " bytes; your request body was "
|
||||
, (LS8.pack (show bodyLen))
|
||||
, " bytes. If you're the developer of this site, you can configure the maximum length with the `maximumContentLength` or `maximumContentLengthIO` function on the Yesod typeclass."
|
||||
])
|
||||
"Request body too large to be processed."
|
||||
|
||||
parseWaiRequest :: W.Request
|
||||
-> SessionMap
|
||||
-> Bool
|
||||
-> Maybe Word64 -- ^ max body size
|
||||
-> Either (IO YesodRequest) (IO Int -> IO YesodRequest)
|
||||
-> Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest)
|
||||
parseWaiRequest env session useToken mmaxBodySize =
|
||||
-- In most cases, we won't need to generate any random values. Therefore,
|
||||
-- we split our results: if we need a random generator, return a Right
|
||||
@ -129,7 +127,7 @@ parseWaiRequest env session useToken mmaxBodySize =
|
||||
-- Already have a token, use it.
|
||||
Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs
|
||||
-- Don't have a token, get a random generator and make a new one.
|
||||
Nothing -> Right $ fmap Just . randomString 40
|
||||
Nothing -> Right $ fmap Just . randomString 10
|
||||
| otherwise = Left Nothing
|
||||
|
||||
textQueryString :: W.Request -> [(Text, Text)]
|
||||
@ -158,21 +156,16 @@ addTwoLetters (toAdd, exist) (l:ls) =
|
||||
-- | Generate a random String of alphanumerical characters
|
||||
-- (a-z, A-Z, and 0-9) of the given length using the given
|
||||
-- random number generator.
|
||||
randomString :: Monad m => Int -> m Int -> m Text
|
||||
randomString :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m Text
|
||||
randomString len gen =
|
||||
liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar
|
||||
where
|
||||
asciiChar =
|
||||
let loop = do
|
||||
x <- gen
|
||||
let y = fromIntegral $ x `mod` 64
|
||||
case () of
|
||||
()
|
||||
| y < 26 -> return $ y + Word8._A
|
||||
| y < 52 -> return $ y + Word8._a - 26
|
||||
| y < 62 -> return $ y + Word8._0 - 52
|
||||
| otherwise -> loop
|
||||
in loop
|
||||
asciiChar = liftM toAscii $ MWC.uniformR (0, 61) gen
|
||||
|
||||
toAscii i
|
||||
| i < 26 = i + Word8._A
|
||||
| i < 52 = i + Word8._a - 26
|
||||
| otherwise = i + Word8._0 - 52
|
||||
|
||||
fromByteVector :: V.Vector Word8 -> ByteString
|
||||
fromByteVector v =
|
||||
@ -183,13 +176,13 @@ fromByteVector v =
|
||||
|
||||
mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
|
||||
mkFileInfoLBS name ct lbs =
|
||||
FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs)
|
||||
FileInfo name ct (sourceList $ L.toChunks lbs) (`L.writeFile` lbs)
|
||||
|
||||
mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo
|
||||
mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runConduitRes $ sourceFile fp .| sinkFile dst)
|
||||
mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)
|
||||
|
||||
mkFileInfoSource :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo
|
||||
mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst)
|
||||
mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo
|
||||
mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)
|
||||
|
||||
tokenKey :: IsString a => a
|
||||
tokenKey = "_TOKEN"
|
||||
@ -6,24 +6,29 @@ module Yesod.Core.Internal.Response where
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Network.Wai
|
||||
import Control.Monad (mplus)
|
||||
import Control.Monad.Trans.Resource (runInternalState, InternalState)
|
||||
import Network.Wai.Internal
|
||||
#if !MIN_VERSION_base(4, 6, 0)
|
||||
import Prelude hiding (catch)
|
||||
#endif
|
||||
import Web.Cookie (renderSetCookie)
|
||||
import Yesod.Core.Content
|
||||
import Yesod.Core.Types
|
||||
import qualified Network.HTTP.Types as H
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception (SomeException, handle)
|
||||
import Data.ByteString.Builder (lazyByteString, toLazyByteString)
|
||||
import Blaze.ByteString.Builder (fromLazyByteString,
|
||||
toLazyByteString, toByteString)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Map as Map
|
||||
import Yesod.Core.Internal.Request (tokenKey)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Conduit
|
||||
import Data.Conduit (Flush (..), ($$), transPipe)
|
||||
import qualified Data.Conduit.List as CL
|
||||
|
||||
yarToResponse :: YesodResponse
|
||||
-> (SessionMap -> IO [Header]) -- ^ save session
|
||||
@ -51,9 +56,9 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse
|
||||
sendResponse $ ResponseBuilder s hs' b
|
||||
go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p
|
||||
go (ContentSource body) = sendResponse $ responseStream s finalHeaders
|
||||
$ \sendChunk flush -> runConduit $
|
||||
$ \sendChunk flush ->
|
||||
transPipe (`runInternalState` is) body
|
||||
.| mapM_C (\mchunk ->
|
||||
$$ CL.mapM_ (\mchunk ->
|
||||
case mchunk of
|
||||
Flush -> flush
|
||||
Chunk builder -> sendChunk builder)
|
||||
@ -81,7 +86,7 @@ defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"
|
||||
headerToPair :: Header
|
||||
-> (CI ByteString, ByteString)
|
||||
headerToPair (AddCookie sc) =
|
||||
("Set-Cookie", BL.toStrict $ toLazyByteString $ renderSetCookie sc)
|
||||
("Set-Cookie", toByteString $ renderSetCookie sc)
|
||||
headerToPair (DeleteCookie key path) =
|
||||
( "Set-Cookie"
|
||||
, S.concat
|
||||
@ -91,14 +96,14 @@ headerToPair (DeleteCookie key path) =
|
||||
, "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
|
||||
]
|
||||
)
|
||||
headerToPair (Header key value) = (key, value)
|
||||
headerToPair (Header key value) = (CI.mk key, value)
|
||||
|
||||
evaluateContent :: Content -> IO (Either ErrorResponse Content)
|
||||
evaluateContent (ContentBuilder b mlen) = handle f $ do
|
||||
let lbs = toLazyByteString b
|
||||
len = L.length lbs
|
||||
mlen' = mlen `mplus` Just (fromIntegral len)
|
||||
len `seq` return (Right $ ContentBuilder (lazyByteString lbs) mlen')
|
||||
len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')
|
||||
where
|
||||
f :: SomeException -> IO (Either ErrorResponse Content)
|
||||
f = return . Left . InternalError . T.pack . show
|
||||
@ -1,31 +1,22 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Yesod.Core.Internal.Run
|
||||
( toErrorHandler
|
||||
, errFromShow
|
||||
, basicRunHandler
|
||||
, handleError
|
||||
, handleContents
|
||||
, evalFallback
|
||||
, runHandler
|
||||
, safeEh
|
||||
, runFakeHandler
|
||||
, yesodRunner
|
||||
, yesodRender
|
||||
, resolveApproot
|
||||
)
|
||||
where
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Core.Internal.Run where
|
||||
|
||||
import qualified Control.Exception as EUnsafe
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Data.Monoid (Monoid, mempty)
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Yesod.Core.Internal.Response
|
||||
import Data.ByteString.Builder (toLazyByteString)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Blaze.ByteString.Builder (toByteString)
|
||||
import Control.Exception (fromException, evaluate)
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
|
||||
liftLoc)
|
||||
@ -53,31 +44,46 @@ import Yesod.Core.Internal.Request (parseWaiRequest,
|
||||
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
|
||||
import Yesod.Routes.Class (Route, renderRoute)
|
||||
import Control.DeepSeq (($!!), NFData)
|
||||
import UnliftIO.Exception
|
||||
import UnliftIO(MonadUnliftIO, withRunInIO)
|
||||
import Data.Proxy(Proxy(..))
|
||||
|
||||
-- | Convert a synchronous exception into an ErrorResponse
|
||||
toErrorHandler :: SomeException -> IO ErrorResponse
|
||||
toErrorHandler e0 = handleAny errFromShow $
|
||||
-- | Catch all synchronous exceptions, ignoring asynchronous
|
||||
-- exceptions.
|
||||
--
|
||||
-- Ideally we'd use this from a different library
|
||||
catchSync :: IO a -> (E.SomeException -> IO a) -> IO a
|
||||
catchSync thing after = thing `E.catch` \e ->
|
||||
if isAsyncException e
|
||||
then E.throwIO e
|
||||
else after e
|
||||
|
||||
-- | Determine if an exception is asynchronous
|
||||
--
|
||||
-- Also worth being upstream
|
||||
isAsyncException :: E.SomeException -> Bool
|
||||
isAsyncException e =
|
||||
case fromException e of
|
||||
Just E.SomeAsyncException{} -> True
|
||||
Nothing -> False
|
||||
|
||||
-- | Convert an exception into an ErrorResponse
|
||||
toErrorHandler :: E.SomeException -> IO ErrorResponse
|
||||
toErrorHandler e0 = flip catchSync errFromShow $
|
||||
case fromException e0 of
|
||||
Just (HCError x) -> evaluate $!! x
|
||||
_ -> errFromShow e0
|
||||
_
|
||||
| isAsyncException e0 -> E.throwIO e0
|
||||
| otherwise -> errFromShow e0
|
||||
|
||||
-- | Generate an @ErrorResponse@ based on the shown version of the exception
|
||||
errFromShow :: SomeException -> IO ErrorResponse
|
||||
errFromShow x = do
|
||||
text <- evaluate (T.pack $ show x) `catchAny` \_ ->
|
||||
return (T.pack "Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception")
|
||||
return $ InternalError text
|
||||
errFromShow :: E.SomeException -> IO ErrorResponse
|
||||
errFromShow x = evaluate $!! InternalError $! T.pack $! show x
|
||||
|
||||
-- | Do a basic run of a handler, getting some contents and the final
|
||||
-- @GHState@. The @GHState@ unfortunately may contain some impure
|
||||
-- exceptions, but all other synchronous exceptions will be caught and
|
||||
-- represented by the @HandlerContents@.
|
||||
basicRunHandler :: ToTypedContent c
|
||||
=> RunHandlerEnv site site
|
||||
-> HandlerFor site c
|
||||
=> RunHandlerEnv site
|
||||
-> HandlerT site IO c
|
||||
-> YesodRequest
|
||||
-> InternalState
|
||||
-> IO (GHState, HandlerContents)
|
||||
@ -88,9 +94,9 @@ basicRunHandler rhe handler yreq resState = do
|
||||
|
||||
-- Run the handler itself, capturing any runtime exceptions and
|
||||
-- converting them into a @HandlerContents@
|
||||
contents' <- rheCatchHandlerExceptions rhe
|
||||
contents' <- catchSync
|
||||
(do
|
||||
res <- unHandlerFor handler (hd istate)
|
||||
res <- unHandlerT handler (hd istate)
|
||||
tc <- evaluate (toTypedContent res)
|
||||
-- Success! Wrap it up in an @HCContent@
|
||||
return (HCContent defaultStatus tc))
|
||||
@ -115,11 +121,12 @@ basicRunHandler rhe handler yreq resState = do
|
||||
{ handlerRequest = yreq
|
||||
, handlerEnv = rhe
|
||||
, handlerState = istate
|
||||
, handlerToParent = const ()
|
||||
, handlerResource = resState
|
||||
}
|
||||
|
||||
-- | Convert an @ErrorResponse@ into a @YesodResponse@
|
||||
handleError :: RunHandlerEnv sub site
|
||||
handleError :: RunHandlerEnv site
|
||||
-> YesodRequest
|
||||
-> InternalState
|
||||
-> Map.Map Text S8.ByteString
|
||||
@ -128,7 +135,7 @@ handleError :: RunHandlerEnv sub site
|
||||
-> IO YesodResponse
|
||||
handleError rhe yreq resState finalSession headers e0 = do
|
||||
-- Find any evil hidden impure exceptions
|
||||
e <- (evaluate $!! e0) `catchAny` errFromShow
|
||||
e <- (evaluate $!! e0) `catchSync` errFromShow
|
||||
|
||||
-- Generate a response, leveraging the updated session and
|
||||
-- response headers
|
||||
@ -189,22 +196,19 @@ handleContents handleError' finalSession headers contents =
|
||||
-- | Evaluate the given value. If an exception is thrown, use it to
|
||||
-- replace the provided contents and then return @mempty@ in place of the
|
||||
-- evaluated value.
|
||||
--
|
||||
-- Note that this also catches async exceptions.
|
||||
evalFallback :: (Monoid w, NFData w)
|
||||
=> (forall a. IO a -> (SomeException -> IO a) -> IO a)
|
||||
-> HandlerContents
|
||||
=> HandlerContents
|
||||
-> w
|
||||
-> IO (w, HandlerContents)
|
||||
evalFallback catcher contents val = catcher
|
||||
evalFallback contents val = catchSync
|
||||
(fmap (, contents) (evaluate $!! val))
|
||||
(fmap ((mempty, ) . HCError) . toErrorHandler)
|
||||
|
||||
-- | Function used internally by Yesod in the process of converting a
|
||||
-- 'HandlerFor' into an 'Application'. Should not be needed by users.
|
||||
-- 'HandlerT' into an 'Application'. Should not be needed by users.
|
||||
runHandler :: ToTypedContent c
|
||||
=> RunHandlerEnv site site
|
||||
-> HandlerFor site c
|
||||
=> RunHandlerEnv site
|
||||
-> HandlerT site IO c
|
||||
-> YesodApp
|
||||
runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
|
||||
-- Get the raw state and original contents
|
||||
@ -212,16 +216,15 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
|
||||
|
||||
-- Evaluate the unfortunately-lazy session and headers,
|
||||
-- propagating exceptions into the contents
|
||||
(finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)
|
||||
(headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
|
||||
contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
|
||||
(finalSession, contents1) <- evalFallback contents0 (ghsSession state)
|
||||
(headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
|
||||
|
||||
-- Convert the HandlerContents into the final YesodResponse
|
||||
handleContents
|
||||
(handleError rhe yreq resState finalSession headers)
|
||||
finalSession
|
||||
headers
|
||||
contents3
|
||||
contents2
|
||||
|
||||
safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
|
||||
-> ErrorResponse
|
||||
@ -236,31 +239,31 @@ safeEh log' er req = do
|
||||
(toContent ("Internal Server Error" :: S.ByteString))
|
||||
(reqSession req)
|
||||
|
||||
-- | Run a 'HandlerFor' completely outside of Yesod. This
|
||||
-- | Run a 'HandlerT' completely outside of Yesod. This
|
||||
-- function comes with many caveats and you shouldn't use it
|
||||
-- unless you fully understand what it's doing and how it works.
|
||||
--
|
||||
-- As of now, there's only one reason to use this function at
|
||||
-- all: in order to run unit tests of functions inside 'HandlerFor'
|
||||
-- all: in order to run unit tests of functions inside 'HandlerT'
|
||||
-- but that aren't easily testable with a full HTTP request.
|
||||
-- Even so, it's better to use @wai-test@ or @yesod-test@ instead
|
||||
-- of using this function.
|
||||
--
|
||||
-- This function will create a fake HTTP request (both @wai@'s
|
||||
-- 'Request' and @yesod@'s 'Request') and feed it to the
|
||||
-- @HandlerFor@. The only useful information the @HandlerFor@ may
|
||||
-- @HandlerT@. The only useful information the @HandlerT@ may
|
||||
-- get from the request is the session map, which you must supply
|
||||
-- as argument to @runFakeHandler@. All other fields contain
|
||||
-- fake information, which means that they can be accessed but
|
||||
-- won't have any useful information. The response of the
|
||||
-- @HandlerFor@ is completely ignored, including changes to the
|
||||
-- @HandlerT@ is completely ignored, including changes to the
|
||||
-- session, cookies or headers. We only return you the
|
||||
-- @HandlerFor@'s return value.
|
||||
runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
|
||||
-- @HandlerT@'s return value.
|
||||
runFakeHandler :: (Yesod site, MonadIO m) =>
|
||||
SessionMap
|
||||
-> (site -> Logger)
|
||||
-> site
|
||||
-> HandlerFor site a
|
||||
-> HandlerT site IO a
|
||||
-> m (Either ErrorResponse a)
|
||||
runFakeHandler fakeSessionMap logger site handler = liftIO $ do
|
||||
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
|
||||
@ -270,14 +273,11 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
|
||||
RunHandlerEnv
|
||||
{ rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
|
||||
, rheRoute = Nothing
|
||||
, rheRouteToMaster = id
|
||||
, rheChild = site
|
||||
, rheSite = site
|
||||
, rheUpload = fileUpload site
|
||||
, rheLog = messageLoggerSource site $ logger site
|
||||
, rheOnError = errHandler
|
||||
, rheMaxExpires = maxExpires
|
||||
, rheCatchHandlerExceptions = catchHandlerExceptions site
|
||||
}
|
||||
handler'
|
||||
errHandler err req = do
|
||||
@ -303,8 +303,10 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
|
||||
, vault = mempty
|
||||
, requestBodyLength = KnownLength 0
|
||||
, requestHeaderRange = Nothing
|
||||
#if MIN_VERSION_wai(3,2,0)
|
||||
, requestHeaderReferer = Nothing
|
||||
, requestHeaderUserAgent = Nothing
|
||||
#endif
|
||||
}
|
||||
fakeRequest =
|
||||
YesodRequest
|
||||
@ -319,51 +321,46 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
|
||||
_ <- runResourceT $ yapp fakeRequest
|
||||
I.readIORef ret
|
||||
|
||||
yesodRunner :: forall res site . (ToTypedContent res, Yesod site)
|
||||
=> HandlerFor site res
|
||||
yesodRunner :: (ToTypedContent res, Yesod site)
|
||||
=> HandlerT site IO res
|
||||
-> YesodRunnerEnv site
|
||||
-> Maybe (Route site)
|
||||
-> Application
|
||||
yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
|
||||
mmaxLen <- maximumContentLengthIO yreSite route
|
||||
case (mmaxLen, requestBodyLength req) of
|
||||
(Just maxLen, KnownLength len) | maxLen < len -> sendResponse (tooLargeResponse maxLen len)
|
||||
_ -> do
|
||||
let dontSaveSession _ = return []
|
||||
(session, saveSession) <- liftIO $
|
||||
maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend
|
||||
maxExpires <- yreGetMaxExpires
|
||||
let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
|
||||
let yreq =
|
||||
case mkYesodReq of
|
||||
Left yreq' -> yreq'
|
||||
Right needGen -> needGen yreGen
|
||||
let ra = resolveApproot yreSite req
|
||||
let log' = messageLoggerSource yreSite yreLogger
|
||||
-- We set up two environments: the first one has a "safe" error handler
|
||||
-- which will never throw an exception. The second one uses the
|
||||
-- user-provided errorHandler function. If that errorHandler function
|
||||
-- errors out, it will use the safeEh below to recover.
|
||||
rheSafe = RunHandlerEnv
|
||||
{ rheRender = yesodRender yreSite ra
|
||||
, rheRoute = route
|
||||
, rheRouteToMaster = id
|
||||
, rheChild = yreSite
|
||||
, rheSite = yreSite
|
||||
, rheUpload = fileUpload yreSite
|
||||
, rheLog = log'
|
||||
, rheOnError = safeEh log'
|
||||
, rheMaxExpires = maxExpires
|
||||
, rheCatchHandlerExceptions = catchHandlerExceptions yreSite
|
||||
}
|
||||
rhe = rheSafe
|
||||
{ rheOnError = runHandler rheSafe . errorHandler
|
||||
}
|
||||
yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
|
||||
| Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse tooLargeResponse
|
||||
| otherwise = do
|
||||
let dontSaveSession _ = return []
|
||||
(session, saveSession) <- liftIO $
|
||||
maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend
|
||||
maxExpires <- yreGetMaxExpires
|
||||
let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
|
||||
let yreq =
|
||||
case mkYesodReq of
|
||||
Left yreq' -> yreq'
|
||||
Right needGen -> needGen yreGen
|
||||
let ra = resolveApproot yreSite req
|
||||
let log' = messageLoggerSource yreSite yreLogger
|
||||
-- We set up two environments: the first one has a "safe" error handler
|
||||
-- which will never throw an exception. The second one uses the
|
||||
-- user-provided errorHandler function. If that errorHandler function
|
||||
-- errors out, it will use the safeEh below to recover.
|
||||
rheSafe = RunHandlerEnv
|
||||
{ rheRender = yesodRender yreSite ra
|
||||
, rheRoute = route
|
||||
, rheSite = yreSite
|
||||
, rheUpload = fileUpload yreSite
|
||||
, rheLog = log'
|
||||
, rheOnError = safeEh log'
|
||||
, rheMaxExpires = maxExpires
|
||||
}
|
||||
rhe = rheSafe
|
||||
{ rheOnError = runHandler rheSafe . errorHandler
|
||||
}
|
||||
|
||||
yesodWithInternalState yreSite route $ \is -> do
|
||||
yreq' <- yreq
|
||||
yar <- runInternalState (runHandler rhe handler yreq') is
|
||||
yarToResponse yar saveSession yreq' req is sendResponse
|
||||
yesodWithInternalState yreSite route $ \is -> do
|
||||
yreq' <- yreq
|
||||
yar <- runInternalState (runHandler rhe handler yreq') is
|
||||
yarToResponse yar saveSession yreq' req is sendResponse
|
||||
where
|
||||
mmaxLen = maximumContentLength yreSite route
|
||||
handler = yesodMiddleware handler'
|
||||
@ -375,7 +372,7 @@ yesodRender :: Yesod y
|
||||
-> [(Text, Text)] -- ^ url query string
|
||||
-> Text
|
||||
yesodRender y ar url params =
|
||||
decodeUtf8With lenientDecode $ BL.toStrict $ toLazyByteString $
|
||||
decodeUtf8With lenientDecode $ toByteString $
|
||||
fromMaybe
|
||||
(joinPath y ar ps
|
||||
$ params ++ params')
|
||||
198
yesod-core/Yesod/Core/Internal/TH.hs
Normal file
198
yesod-core/Yesod/Core/Internal/TH.hs
Normal file
@ -0,0 +1,198 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Core.Internal.TH where
|
||||
|
||||
import Prelude hiding (exp)
|
||||
import Yesod.Core.Handler
|
||||
|
||||
import Language.Haskell.TH hiding (cxt, instanceD)
|
||||
import Language.Haskell.TH.Syntax
|
||||
|
||||
import qualified Network.Wai as W
|
||||
|
||||
import Data.ByteString.Lazy.Char8 ()
|
||||
import Data.List (foldl')
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad (replicateM, void)
|
||||
import Data.Either (partitionEithers)
|
||||
|
||||
import Yesod.Routes.TH
|
||||
import Yesod.Routes.Parse
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Content
|
||||
import Yesod.Core.Class.Dispatch
|
||||
import Yesod.Core.Internal.Run
|
||||
|
||||
-- | Generates URL datatype and site function for the given 'Resource's. This
|
||||
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
|
||||
-- Use 'parseRoutes' to create the 'Resource's.
|
||||
mkYesod :: String -- ^ name of the argument datatype
|
||||
-> [ResourceTree String]
|
||||
-> Q [Dec]
|
||||
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False return
|
||||
|
||||
mkYesodWith :: String
|
||||
-> [Either String [String]]
|
||||
-> [ResourceTree String]
|
||||
-> Q [Dec]
|
||||
mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral name args False return
|
||||
|
||||
-- | Sometimes, you will want to declare your routes in one file and define
|
||||
-- your handlers elsewhere. For example, this is the only way to break up a
|
||||
-- monolithic file into smaller parts. Use this function, paired with
|
||||
-- 'mkYesodDispatch', to do just that.
|
||||
mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodData name = mkYesodDataGeneral name False
|
||||
|
||||
mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodSubData name = mkYesodDataGeneral name True
|
||||
|
||||
mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodDataGeneral name isSub res = do
|
||||
let (name':rest) = words name
|
||||
fst <$> mkYesodGeneral name' (fmap Left rest) isSub return res
|
||||
|
||||
-- | See 'mkYesodData'.
|
||||
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return
|
||||
|
||||
-- | Get the Handler and Widget type synonyms for the given site.
|
||||
masterTypeSyns :: [Name] -> Type -> [Dec]
|
||||
masterTypeSyns vs site =
|
||||
[ TySynD (mkName "Handler") (fmap PlainTV vs)
|
||||
$ ConT ''HandlerT `AppT` site `AppT` ConT ''IO
|
||||
, TySynD (mkName "Widget") (fmap PlainTV vs)
|
||||
$ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
|
||||
]
|
||||
|
||||
-- | 'Left' arguments indicate a monomorphic type, a 'Right' argument
|
||||
-- indicates a polymorphic type, and provides the list of classes
|
||||
-- the type must be instance of.
|
||||
mkYesodGeneral :: String -- ^ foundation type
|
||||
-> [Either String [String]] -- ^ arguments for the type
|
||||
-> Bool -- ^ is this a subsite
|
||||
-> (Exp -> Q Exp) -- ^ unwrap handler
|
||||
-> [ResourceTree String]
|
||||
-> Q([Dec],[Dec])
|
||||
mkYesodGeneral namestr args isSub f resS = do
|
||||
mname <- lookupTypeName namestr
|
||||
arity <- case mname of
|
||||
Just name -> do
|
||||
info <- reify name
|
||||
return $
|
||||
case info of
|
||||
TyConI dec ->
|
||||
case dec of
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
DataD _ _ vs _ _ _ -> length vs
|
||||
NewtypeD _ _ vs _ _ _ -> length vs
|
||||
#else
|
||||
DataD _ _ vs _ _ -> length vs
|
||||
NewtypeD _ _ vs _ _ -> length vs
|
||||
#endif
|
||||
_ -> 0
|
||||
_ -> 0
|
||||
_ -> return 0
|
||||
let name = mkName namestr
|
||||
(mtys,_) = partitionEithers args
|
||||
-- Generate as many variable names as the arity indicates
|
||||
vns <- replicateM (arity - length mtys) $ newName "t"
|
||||
-- Base type (site type with variables)
|
||||
let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $
|
||||
foldr (\arg (xs,n:ns,cs) ->
|
||||
case arg of
|
||||
Left t -> ( ConT (mkName t):xs, n:ns, cs )
|
||||
Right ts -> ( VarT n :xs, ns
|
||||
, fmap (\t ->
|
||||
#if MIN_VERSION_template_haskell(2,10,0)
|
||||
AppT (ConT $ mkName t) (VarT n)
|
||||
#else
|
||||
ClassP (mkName t) [VarT n]
|
||||
#endif
|
||||
) ts ++ cs )
|
||||
) ([],vns,[]) args
|
||||
site = foldl' AppT (ConT name) argtypes
|
||||
res = map (fmap parseType) resS
|
||||
renderRouteDec <- mkRenderRouteInstance site res
|
||||
routeAttrsDec <- mkRouteAttrsInstance site res
|
||||
dispatchDec <- mkDispatchInstance site cxt f res
|
||||
parse <- mkParseRouteInstance site res
|
||||
let rname = mkName $ "resources" ++ namestr
|
||||
eres <- lift resS
|
||||
let resourcesDec =
|
||||
[ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
|
||||
, FunD rname [Clause [] (NormalB eres) []]
|
||||
]
|
||||
let dataDec = concat
|
||||
[ [parse]
|
||||
, renderRouteDec
|
||||
, [routeAttrsDec]
|
||||
, resourcesDec
|
||||
, if isSub then [] else masterTypeSyns vns site
|
||||
]
|
||||
return (dataDec, dispatchDec)
|
||||
|
||||
mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
|
||||
mkMDS f rh = MkDispatchSettings
|
||||
{ mdsRunHandler = rh
|
||||
, mdsSubDispatcher =
|
||||
[|\parentRunner getSub toParent env -> yesodSubDispatch
|
||||
YesodSubRunnerEnv
|
||||
{ ysreParentRunner = parentRunner
|
||||
, ysreGetSub = getSub
|
||||
, ysreToParentRoute = toParent
|
||||
, ysreParentEnv = env
|
||||
}
|
||||
|]
|
||||
, mdsGetPathInfo = [|W.pathInfo|]
|
||||
, mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
|
||||
, mdsMethod = [|W.requestMethod|]
|
||||
, mds404 = [|void notFound|]
|
||||
, mds405 = [|void badMethod|]
|
||||
, mdsGetHandler = defaultGetHandler
|
||||
, mdsUnwrapper = f
|
||||
}
|
||||
|
||||
-- | If the generation of @'YesodDispatch'@ instance require finer
|
||||
-- control of the types, contexts etc. using this combinator. You will
|
||||
-- hardly need this generality. However, in certain situations, like
|
||||
-- when writing library/plugin for yesod, this combinator becomes
|
||||
-- handy.
|
||||
mkDispatchInstance :: Type -- ^ The master site type
|
||||
-> Cxt -- ^ Context of the instance
|
||||
-> (Exp -> Q Exp) -- ^ Unwrap handler
|
||||
-> [ResourceTree c] -- ^ The resource
|
||||
-> DecsQ
|
||||
mkDispatchInstance master cxt f res = do
|
||||
clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res
|
||||
let thisDispatch = FunD 'yesodDispatch [clause']
|
||||
return [instanceD cxt yDispatch [thisDispatch]]
|
||||
where
|
||||
yDispatch = ConT ''YesodDispatch `AppT` master
|
||||
|
||||
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
|
||||
mkYesodSubDispatch res = do
|
||||
clause' <- mkDispatchClause (mkMDS return [|subHelper . fmap toTypedContent|]) res
|
||||
inner <- newName "inner"
|
||||
let innerFun = FunD inner [clause']
|
||||
helper <- newName "helper"
|
||||
let fun = FunD helper
|
||||
[ Clause
|
||||
[]
|
||||
(NormalB $ VarE inner)
|
||||
[innerFun]
|
||||
]
|
||||
return $ LetE [fun] (VarE helper)
|
||||
|
||||
instanceD :: Cxt -> Type -> [Dec] -> Dec
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
instanceD = InstanceD Nothing
|
||||
#else
|
||||
instanceD = InstanceD
|
||||
#endif
|
||||
@ -13,7 +13,12 @@ import Data.Serialize (Get, Put, Serialize (..))
|
||||
import qualified Data.Text as T
|
||||
import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay),
|
||||
DiffTime, UTCTime (..), formatTime,
|
||||
getCurrentTime, addUTCTime, defaultTimeLocale)
|
||||
getCurrentTime, addUTCTime)
|
||||
#if MIN_VERSION_time(1,5,0)
|
||||
import Data.Time (defaultTimeLocale)
|
||||
#else
|
||||
import System.Locale (defaultTimeLocale)
|
||||
#endif
|
||||
|
||||
putTime :: UTCTime -> Put
|
||||
putTime (UTCTime d t) =
|
||||
@ -6,15 +6,12 @@ module Yesod.Core.Json
|
||||
defaultLayoutJson
|
||||
, jsonToRepJson
|
||||
, returnJson
|
||||
#if MIN_VERSION_aeson(0, 11, 0)
|
||||
, returnJsonEncoding
|
||||
#endif
|
||||
, provideJson
|
||||
|
||||
-- * Convert to a JSON value
|
||||
, parseCheckJsonBody
|
||||
, parseInsecureJsonBody
|
||||
, requireCheckJsonBody
|
||||
, requireInsecureJsonBody
|
||||
-- ** Deprecated JSON conversion
|
||||
, parseJsonBody
|
||||
, parseJsonBody_
|
||||
, requireJsonBody
|
||||
@ -30,21 +27,20 @@ module Yesod.Core.Json
|
||||
|
||||
-- * Convenience functions
|
||||
, jsonOrRedirect
|
||||
#if MIN_VERSION_aeson(0, 11, 0)
|
||||
, jsonEncodingOrRedirect
|
||||
#endif
|
||||
, acceptsJson
|
||||
|
||||
-- * Checking if data is JSON
|
||||
, contentTypeHeaderIsJson
|
||||
) where
|
||||
|
||||
import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)
|
||||
import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep)
|
||||
import Control.Monad.Trans.Writer (Writer)
|
||||
import Data.Monoid (Endo)
|
||||
import Yesod.Core.Content (TypedContent)
|
||||
import Yesod.Core.Types (reqAccept)
|
||||
import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
|
||||
import Yesod.Core.Class.Handler
|
||||
import Yesod.Core.Widget (WidgetFor)
|
||||
import Yesod.Core.Widget (WidgetT)
|
||||
import Yesod.Routes.Class
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Parser as JP
|
||||
@ -64,12 +60,16 @@ import Control.Monad (liftM)
|
||||
--
|
||||
-- @since 0.3.0
|
||||
defaultLayoutJson :: (Yesod site, J.ToJSON a)
|
||||
=> WidgetFor site () -- ^ HTML
|
||||
-> HandlerFor site a -- ^ JSON
|
||||
-> HandlerFor site TypedContent
|
||||
=> WidgetT site IO () -- ^ HTML
|
||||
-> HandlerT site IO a -- ^ JSON
|
||||
-> HandlerT site IO TypedContent
|
||||
defaultLayoutJson w json = selectRep $ do
|
||||
provideRep $ defaultLayout w
|
||||
#if MIN_VERSION_aeson(0, 11, 0)
|
||||
provideRep $ fmap J.toEncoding json
|
||||
#else
|
||||
provideRep $ fmap J.toJSON json
|
||||
#endif
|
||||
|
||||
-- | Wraps a data type in a 'RepJson'. The data type must
|
||||
-- support conversion to JSON via 'J.ToJSON'.
|
||||
@ -85,90 +85,53 @@ jsonToRepJson = return . J.toJSON
|
||||
returnJson :: (Monad m, J.ToJSON a) => a -> m J.Value
|
||||
returnJson = return . J.toJSON
|
||||
|
||||
#if MIN_VERSION_aeson(0, 11, 0)
|
||||
-- | Convert a value to a JSON representation via aeson\'s 'J.toEncoding' function.
|
||||
--
|
||||
-- @since 1.4.21
|
||||
returnJsonEncoding :: (Monad m, J.ToJSON a) => a -> m J.Encoding
|
||||
returnJsonEncoding = return . J.toEncoding
|
||||
#endif
|
||||
|
||||
-- | Provide a JSON representation for usage with 'selectReps', using aeson\'s
|
||||
-- 'J.toJSON' (aeson >= 0.11: 'J.toEncoding') function to perform the conversion.
|
||||
--
|
||||
-- @since 1.2.1
|
||||
provideJson :: (Monad m, J.ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()
|
||||
#if MIN_VERSION_aeson(0, 11, 0)
|
||||
provideJson = provideRep . return . J.toEncoding
|
||||
|
||||
-- | Same as 'parseInsecureJsonBody'
|
||||
--
|
||||
-- @since 0.3.0
|
||||
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
|
||||
parseJsonBody = parseInsecureJsonBody
|
||||
{-# DEPRECATED parseJsonBody "Use parseCheckJsonBody or parseInsecureJsonBody instead" #-}
|
||||
|
||||
-- | Same as 'parseCheckJsonBody', but does not check that the mime type
|
||||
-- indicates JSON content.
|
||||
--
|
||||
-- Note: This function is vulnerable to CSRF attacks.
|
||||
--
|
||||
-- @since 1.6.11
|
||||
parseInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
|
||||
parseInsecureJsonBody = do
|
||||
eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')
|
||||
return $ case eValue of
|
||||
Left e -> J.Error $ show e
|
||||
Right value -> J.fromJSON value
|
||||
#else
|
||||
provideJson = provideRep . return . J.toJSON
|
||||
#endif
|
||||
|
||||
-- | Parse the request body to a data type as a JSON value. The
|
||||
-- data type must support conversion from JSON via 'J.FromJSON'.
|
||||
-- If you want the raw JSON value, just ask for a @'J.Result'
|
||||
-- 'J.Value'@.
|
||||
--
|
||||
-- The MIME type must indicate JSON content. Requiring a JSON
|
||||
-- content-type helps secure your site against CSRF attacks
|
||||
-- (browsers will perform POST requests for form and text/plain
|
||||
-- content-types without doing a CORS check, and those content-types
|
||||
-- can easily contain valid JSON).
|
||||
--
|
||||
-- Note that this function will consume the request body. As such, calling it
|
||||
-- twice will result in a parse error on the second call, since the request
|
||||
-- body will no longer be available.
|
||||
--
|
||||
-- @since 0.3.0
|
||||
parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
|
||||
parseCheckJsonBody = do
|
||||
mct <- lookupHeader "content-type"
|
||||
case fmap contentTypeHeaderIsJson mct of
|
||||
Just True -> parseInsecureJsonBody
|
||||
_ -> return $ J.Error $ "Non-JSON content type: " ++ show mct
|
||||
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
|
||||
parseJsonBody = do
|
||||
eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value')
|
||||
return $ case eValue of
|
||||
Left e -> J.Error $ show e
|
||||
Right value -> J.fromJSON value
|
||||
|
||||
-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
|
||||
-- | Same as 'parseJsonBody', but return an invalid args response on a parse
|
||||
-- error.
|
||||
parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
|
||||
parseJsonBody_ = requireInsecureJsonBody
|
||||
{-# DEPRECATED parseJsonBody_ "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}
|
||||
parseJsonBody_ = requireJsonBody
|
||||
{-# DEPRECATED parseJsonBody_ "Use requireJsonBody instead" #-}
|
||||
|
||||
-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
|
||||
-- | Same as 'parseJsonBody', but return an invalid args response on a parse
|
||||
-- error.
|
||||
requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a
|
||||
requireJsonBody = requireInsecureJsonBody
|
||||
{-# DEPRECATED requireJsonBody "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}
|
||||
|
||||
-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
|
||||
-- error.
|
||||
--
|
||||
-- @since 1.6.11
|
||||
requireInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m a
|
||||
requireInsecureJsonBody = do
|
||||
ra <- parseInsecureJsonBody
|
||||
case ra of
|
||||
J.Error s -> invalidArgs [pack s]
|
||||
J.Success a -> return a
|
||||
|
||||
-- | Same as 'parseCheckJsonBody', but return an invalid args response on a parse
|
||||
-- error.
|
||||
requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a
|
||||
requireCheckJsonBody = do
|
||||
ra <- parseCheckJsonBody
|
||||
requireJsonBody = do
|
||||
ra <- parseJsonBody
|
||||
case ra of
|
||||
J.Error s -> invalidArgs [pack s]
|
||||
J.Success a -> return a
|
||||
@ -190,6 +153,7 @@ jsonOrRedirect :: (MonadHandler m, J.ToJSON a)
|
||||
-> m J.Value
|
||||
jsonOrRedirect = jsonOrRedirect' J.toJSON
|
||||
|
||||
#if MIN_VERSION_aeson(0, 11, 0)
|
||||
-- | jsonEncodingOrRedirect simplifies the scenario where a POST handler sends a different
|
||||
-- response based on Accept headers:
|
||||
--
|
||||
@ -203,8 +167,9 @@ jsonEncodingOrRedirect :: (MonadHandler m, J.ToJSON a)
|
||||
-> a -- ^ Data to send via JSON
|
||||
-> m J.Encoding
|
||||
jsonEncodingOrRedirect = jsonOrRedirect' J.toEncoding
|
||||
#endif
|
||||
|
||||
jsonOrRedirect' :: MonadHandler m
|
||||
jsonOrRedirect' :: (MonadHandler m, J.ToJSON a)
|
||||
=> (a -> b)
|
||||
-> Route (HandlerSite m) -- ^ Redirect target
|
||||
-> a -- ^ Data to send via JSON
|
||||
@ -221,12 +186,3 @@ acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
|
||||
. listToMaybe
|
||||
. reqAccept)
|
||||
`liftM` getRequest
|
||||
|
||||
-- | Given the @Content-Type@ header, returns if it is JSON.
|
||||
--
|
||||
-- This function is currently a simple check for @application/json@, but in the future may check for
|
||||
-- alternative representations such as @<https://tools.ietf.org/html/rfc6839#section-3.1 xxx/yyy+json>@.
|
||||
--
|
||||
-- @since 1.6.17
|
||||
contentTypeHeaderIsJson :: B8.ByteString -> Bool
|
||||
contentTypeHeaderIsJson bs = B8.takeWhile (/= ';') bs == "application/json"
|
||||
@ -7,7 +7,7 @@
|
||||
-- Note that a TypeRep is unique to a module in a package, so types from different modules will not conflict if they have the same name.
|
||||
--
|
||||
-- used in 'Yesod.Core.Handler.cached' and 'Yesod.Core.Handler.cachedBy'
|
||||
module Yesod.Core.TypeCache (cached, cacheGet, cacheSet, cachedBy, cacheByGet, cacheBySet, TypeMap, KeyedTypeMap) where
|
||||
module Yesod.Core.TypeCache (cached, cachedBy, TypeMap, KeyedTypeMap) where
|
||||
|
||||
import Prelude hiding (lookup)
|
||||
import Data.Typeable (Typeable, TypeRep, typeOf)
|
||||
@ -33,30 +33,22 @@ cached :: (Monad m, Typeable a)
|
||||
=> TypeMap
|
||||
-> m a -- ^ cache the result of this action
|
||||
-> m (Either (TypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
|
||||
cached cache action = case cacheGet cache of
|
||||
cached cache action = case clookup cache of
|
||||
Just val -> return $ Right val
|
||||
Nothing -> do
|
||||
val <- action
|
||||
return $ Left (cacheSet val cache, val)
|
||||
|
||||
-- | Retrieves a value from the cache
|
||||
--
|
||||
-- @since 1.6.10
|
||||
cacheGet :: Typeable a => TypeMap -> Maybe a
|
||||
cacheGet cache = res
|
||||
return $ Left (cinsert val cache, val)
|
||||
where
|
||||
res = lookup (typeOf $ fromJust res) cache >>= fromDynamic
|
||||
fromJust :: Maybe a -> a
|
||||
fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
|
||||
clookup :: Typeable a => TypeMap -> Maybe a
|
||||
clookup c =
|
||||
res
|
||||
where
|
||||
res = lookup (typeOf $ fromJust res) c >>= fromDynamic
|
||||
fromJust :: Maybe a -> a
|
||||
fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
|
||||
|
||||
-- | Sets a value in the cache
|
||||
--
|
||||
-- @since 1.6.10
|
||||
cacheSet :: (Typeable a)
|
||||
=> a
|
||||
-> TypeMap
|
||||
-> TypeMap
|
||||
cacheSet v cache = insert (typeOf v) (toDyn v) cache
|
||||
cinsert :: Typeable a => a -> TypeMap -> TypeMap
|
||||
cinsert v = insert (typeOf v) (toDyn v)
|
||||
|
||||
-- | similar to 'cached'.
|
||||
-- 'cached' can only cache a single value per type.
|
||||
@ -73,24 +65,19 @@ cachedBy :: (Monad m, Typeable a)
|
||||
-> ByteString -- ^ a cache key
|
||||
-> m a -- ^ cache the result of this action
|
||||
-> m (Either (KeyedTypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
|
||||
cachedBy cache k action = case cacheByGet k cache of
|
||||
cachedBy cache k action = case clookup k cache of
|
||||
Just val -> return $ Right val
|
||||
Nothing -> do
|
||||
val <- action
|
||||
return $ Left (cacheBySet k val cache, val)
|
||||
|
||||
-- | Retrieves a value from the keyed cache
|
||||
--
|
||||
-- @since 1.6.10
|
||||
cacheByGet :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a
|
||||
cacheByGet key c = res
|
||||
return $ Left (cinsert k val cache, val)
|
||||
where
|
||||
res = lookup (typeOf $ fromJust res, key) c >>= fromDynamic
|
||||
fromJust :: Maybe a -> a
|
||||
fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
|
||||
clookup :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a
|
||||
clookup key c =
|
||||
res
|
||||
where
|
||||
res = lookup (typeOf $ fromJust res, key) c >>= fromDynamic
|
||||
fromJust :: Maybe a -> a
|
||||
fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
|
||||
|
||||
-- | Sets a value in the keyed cache
|
||||
--
|
||||
-- @since 1.6.10
|
||||
cacheBySet :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap
|
||||
cacheBySet key v cache = insert (typeOf v, key) (toDyn v) cache
|
||||
cinsert :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap
|
||||
cinsert key v = insert (typeOf v, key) (toDyn v)
|
||||
@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
@ -7,29 +7,32 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Yesod.Core.Types where
|
||||
|
||||
import Data.Aeson (ToJSON)
|
||||
import qualified Data.ByteString.Builder as BB
|
||||
import qualified Blaze.ByteString.Builder as BBuilder
|
||||
import qualified Blaze.ByteString.Builder.Char.Utf8
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative (Applicative (..))
|
||||
import Control.Applicative ((<$>))
|
||||
import Data.Monoid (Monoid (..))
|
||||
#endif
|
||||
import Control.Arrow (first)
|
||||
import Control.Exception (Exception)
|
||||
import Control.Monad (ap)
|
||||
import Control.Monad (liftM, ap)
|
||||
import Control.Monad.Base (MonadBase (liftBase))
|
||||
import Control.Monad.Catch (MonadMask (..), MonadCatch (..))
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Logger (LogLevel, LogSource,
|
||||
MonadLogger (..))
|
||||
import Control.Monad.Primitive (PrimMonad (..))
|
||||
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), monadThrow, ResourceT)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.Conduit (Flush, ConduitT)
|
||||
import Data.IORef (IORef, modifyIORef')
|
||||
import Data.Conduit (Flush, Source)
|
||||
import Data.IORef (IORef)
|
||||
import Data.Map (Map, unionWith)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Monoid (Endo (..), Last (..))
|
||||
import Data.Semigroup (Semigroup(..))
|
||||
import Data.Serialize (Serialize (..),
|
||||
putByteString)
|
||||
import Data.String (IsString (fromString))
|
||||
@ -37,6 +40,7 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy.Builder as TBuilder
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics (Generic)
|
||||
import Language.Haskell.TH.Syntax (Loc)
|
||||
import qualified Network.HTTP.Types as H
|
||||
@ -45,18 +49,27 @@ import Network.Wai (FilePart,
|
||||
import qualified Network.Wai as W
|
||||
import qualified Network.Wai.Parse as NWP
|
||||
import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr)
|
||||
import qualified System.Random.MWC as MWC
|
||||
import Network.Wai.Logger (DateCacheGetter)
|
||||
import Text.Blaze.Html (Html, toHtml)
|
||||
import Text.Hamlet (HtmlUrl)
|
||||
import Text.Julius (JavascriptUrl)
|
||||
import Web.Cookie (SetCookie)
|
||||
import Yesod.Core.Internal.Util (getTime, putTime)
|
||||
import Control.Monad.Trans.Class (MonadTrans (..))
|
||||
import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))
|
||||
import Control.Monad.Reader (MonadReader (..))
|
||||
#if !MIN_VERSION_base(4, 6, 0)
|
||||
import Prelude hiding (catch)
|
||||
#endif
|
||||
import Control.DeepSeq (NFData (rnf))
|
||||
import Control.DeepSeq.Generics (genericRnf)
|
||||
import Data.Conduit.Lazy (MonadActive, monadActive)
|
||||
import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
|
||||
#if MIN_VERSION_monad_logger(0, 3, 10)
|
||||
import Control.Monad.Logger (MonadLoggerIO (..))
|
||||
import UnliftIO (MonadUnliftIO (..), SomeException)
|
||||
#endif
|
||||
import Data.Semigroup (Semigroup)
|
||||
|
||||
-- Sessions
|
||||
type SessionMap = Map Text ByteString
|
||||
@ -69,7 +82,7 @@ newtype SessionBackend = SessionBackend
|
||||
-> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session
|
||||
}
|
||||
|
||||
data SessionCookie = SessionCookie !(Either UTCTime ByteString) !ByteString !SessionMap
|
||||
data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString SessionMap
|
||||
deriving (Show, Read)
|
||||
instance Serialize SessionCookie where
|
||||
put (SessionCookie a b c) = do
|
||||
@ -127,13 +140,13 @@ type RequestBodyContents =
|
||||
data FileInfo = FileInfo
|
||||
{ fileName :: !Text
|
||||
, fileContentType :: !Text
|
||||
, fileSourceRaw :: !(ConduitT () ByteString (ResourceT IO) ())
|
||||
, fileSourceRaw :: !(Source (ResourceT IO) ByteString)
|
||||
, fileMove :: !(FilePath -> IO ())
|
||||
}
|
||||
|
||||
data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
|
||||
| FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)
|
||||
| FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ()))
|
||||
| FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))
|
||||
|
||||
-- | How to determine the root of the application for constructing URLs.
|
||||
--
|
||||
@ -147,13 +160,13 @@ data Approot master = ApprootRelative -- ^ No application root.
|
||||
|
||||
type ResolvedApproot = Text
|
||||
|
||||
data AuthResult = Authorized | AuthenticationRequired | Unauthorized !Text
|
||||
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
|
||||
deriving (Eq, Show, Read)
|
||||
|
||||
data ScriptLoadPosition master
|
||||
= BottomOfBody
|
||||
| BottomOfHeadBlocking
|
||||
| BottomOfHeadAsync !(BottomOfHeadAsync master)
|
||||
| BottomOfHeadAsync (BottomOfHeadAsync master)
|
||||
|
||||
type BottomOfHeadAsync master
|
||||
= [Text] -- ^ urls to load asynchronously
|
||||
@ -162,20 +175,13 @@ type BottomOfHeadAsync master
|
||||
|
||||
type Texts = [Text]
|
||||
|
||||
-- | Wrap up a normal WAI application as a Yesod subsite. Ignore parent site's middleware and isAuthorized.
|
||||
-- | Wrap up a normal WAI application as a Yesod subsite.
|
||||
newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
|
||||
|
||||
-- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized.
|
||||
--
|
||||
-- @since 1.4.34
|
||||
newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }
|
||||
|
||||
data RunHandlerEnv child site = RunHandlerEnv
|
||||
data RunHandlerEnv site = RunHandlerEnv
|
||||
{ rheRender :: !(Route site -> [(Text, Text)] -> Text)
|
||||
, rheRoute :: !(Maybe (Route child))
|
||||
, rheRouteToMaster :: !(Route child -> Route site)
|
||||
, rheRoute :: !(Maybe (Route site))
|
||||
, rheSite :: !site
|
||||
, rheChild :: !child
|
||||
, rheUpload :: !(RequestBodyLength -> FileUpload)
|
||||
, rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
|
||||
, rheOnError :: !(ErrorResponse -> YesodApp)
|
||||
@ -183,17 +189,13 @@ data RunHandlerEnv child site = RunHandlerEnv
|
||||
--
|
||||
-- Since 1.2.0
|
||||
, rheMaxExpires :: !Text
|
||||
|
||||
-- | @since 1.6.24.0
|
||||
-- catch function for rendering 500 pages on exceptions.
|
||||
-- by default this is catch from unliftio (rethrows all async exceptions).
|
||||
, rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m => m a -> (SomeException -> m a) -> m a)
|
||||
}
|
||||
|
||||
data HandlerData child site = HandlerData
|
||||
data HandlerData site parentRoute = HandlerData
|
||||
{ handlerRequest :: !YesodRequest
|
||||
, handlerEnv :: !(RunHandlerEnv child site)
|
||||
, handlerEnv :: !(RunHandlerEnv site)
|
||||
, handlerState :: !(IORef GHState)
|
||||
, handlerToParent :: !(Route site -> parentRoute)
|
||||
, handlerResource :: !InternalState
|
||||
}
|
||||
|
||||
@ -201,83 +203,68 @@ data YesodRunnerEnv site = YesodRunnerEnv
|
||||
{ yreLogger :: !Logger
|
||||
, yreSite :: !site
|
||||
, yreSessionBackend :: !(Maybe SessionBackend)
|
||||
, yreGen :: !(IO Int)
|
||||
-- ^ Generate a random number uniformly distributed in the full
|
||||
-- range of 'Int'.
|
||||
--
|
||||
-- Note: Before 1.6.20, the default value generates pseudo-random
|
||||
-- number in an unspecified range. The range size may not be a power
|
||||
-- of 2. Since 1.6.20, the default value uses a secure entropy source
|
||||
-- and generates in the full range of 'Int'.
|
||||
, yreGetMaxExpires :: !(IO Text)
|
||||
, yreGen :: !MWC.GenIO
|
||||
, yreGetMaxExpires :: IO Text
|
||||
}
|
||||
|
||||
data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv
|
||||
{ ysreParentRunner :: !(ParentRunner parent)
|
||||
data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv
|
||||
{ ysreParentRunner :: !(ParentRunner parent parentMonad)
|
||||
, ysreGetSub :: !(parent -> sub)
|
||||
, ysreToParentRoute :: !(Route sub -> Route parent)
|
||||
, ysreParentEnv :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner?
|
||||
}
|
||||
|
||||
type ParentRunner parent
|
||||
= HandlerFor parent TypedContent
|
||||
type ParentRunner parent m
|
||||
= m TypedContent
|
||||
-> YesodRunnerEnv parent
|
||||
-> Maybe (Route parent)
|
||||
-> W.Application
|
||||
|
||||
-- | A generic handler monad, which can have a different subsite and master
|
||||
-- site. We define a newtype for better error message.
|
||||
newtype HandlerFor site a = HandlerFor
|
||||
{ unHandlerFor :: HandlerData site site -> IO a
|
||||
newtype HandlerT site m a = HandlerT
|
||||
{ unHandlerT :: HandlerData site (MonadRoute m) -> m a
|
||||
}
|
||||
deriving Functor
|
||||
|
||||
type family MonadRoute (m :: * -> *)
|
||||
type instance MonadRoute IO = ()
|
||||
type instance MonadRoute (HandlerT site m) = (Route site)
|
||||
|
||||
data GHState = GHState
|
||||
{ ghsSession :: !SessionMap
|
||||
, ghsRBC :: !(Maybe RequestBodyContents)
|
||||
, ghsIdent :: !Int
|
||||
, ghsCache :: !TypeMap
|
||||
, ghsCacheBy :: !KeyedTypeMap
|
||||
, ghsHeaders :: !(Endo [Header])
|
||||
{ ghsSession :: SessionMap
|
||||
, ghsRBC :: Maybe RequestBodyContents
|
||||
, ghsIdent :: Int
|
||||
, ghsCache :: TypeMap
|
||||
, ghsCacheBy :: KeyedTypeMap
|
||||
, ghsHeaders :: Endo [Header]
|
||||
}
|
||||
|
||||
-- | An extension of the basic WAI 'W.Application' datatype to provide extra
|
||||
-- features needed by Yesod. Users should never need to use this directly, as
|
||||
-- the 'HandlerFor' monad and template haskell code should hide it away.
|
||||
-- the 'HandlerT' monad and template haskell code should hide it away.
|
||||
type YesodApp = YesodRequest -> ResourceT IO YesodResponse
|
||||
|
||||
-- | A generic widget, allowing specification of both the subsite and master
|
||||
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
|
||||
-- better error messages.
|
||||
newtype WidgetFor site a = WidgetFor
|
||||
{ unWidgetFor :: WidgetData site -> IO a
|
||||
newtype WidgetT site m a = WidgetT
|
||||
{ unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site))
|
||||
}
|
||||
deriving Functor
|
||||
|
||||
data WidgetData site = WidgetData
|
||||
{ wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))
|
||||
, wdHandler :: {-# UNPACK #-} !(HandlerData site site)
|
||||
}
|
||||
|
||||
instance a ~ () => Monoid (WidgetFor site a) where
|
||||
instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
|
||||
mempty = return ()
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
mappend = (<>)
|
||||
#endif
|
||||
instance a ~ () => Semigroup (WidgetFor site a) where
|
||||
x <> y = x >> y
|
||||
mappend x y = x >> y
|
||||
instance (a ~ (), Monad m) => Semigroup (WidgetT site m a)
|
||||
|
||||
-- | A 'String' can be trivially promoted to a widget.
|
||||
--
|
||||
-- For example, in a yesod-scaffold site you could use:
|
||||
--
|
||||
-- @getHomeR = do defaultLayout "Widget text"@
|
||||
instance a ~ () => IsString (WidgetFor site a) where
|
||||
instance (Monad m, a ~ ()) => IsString (WidgetT site m a) where
|
||||
fromString = toWidget . toHtml . T.pack
|
||||
where toWidget x = tellWidget mempty { gwdBody = Body (const x) }
|
||||
|
||||
tellWidget :: GWData (Route site) -> WidgetFor site ()
|
||||
tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d)
|
||||
where toWidget x = WidgetT $ const $ return ((), GWData (Body (const x))
|
||||
mempty mempty mempty mempty mempty mempty)
|
||||
|
||||
type RY master = Route master -> [(Text, Text)] -> Text
|
||||
|
||||
@ -295,14 +282,13 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
|
||||
--
|
||||
-- > PageContent url -> HtmlUrl url
|
||||
data PageContent url = PageContent
|
||||
{ pageTitle :: !Html
|
||||
, pageDescription :: !(Maybe Text)
|
||||
, pageHead :: !(HtmlUrl url)
|
||||
, pageBody :: !(HtmlUrl url)
|
||||
{ pageTitle :: Html
|
||||
, pageHead :: HtmlUrl url
|
||||
, pageBody :: HtmlUrl url
|
||||
}
|
||||
|
||||
data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
|
||||
| ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())
|
||||
data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length.
|
||||
| ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder))
|
||||
| ContentFile !FilePath !(Maybe FilePart)
|
||||
| ContentDontEvaluate !Content
|
||||
|
||||
@ -316,20 +302,6 @@ newtype RepXml = RepXml Content
|
||||
|
||||
type ContentType = ByteString -- FIXME Text?
|
||||
|
||||
-- | Wrapper around types so that Handlers can return a domain type, even when
|
||||
-- the data will eventually be encoded as JSON.
|
||||
-- Example usage in a type signature:
|
||||
--
|
||||
-- > postSignupR :: Handler (JSONResponse CreateUserResponse)
|
||||
--
|
||||
-- And in the implementation:
|
||||
--
|
||||
-- > return $ JSONResponse $ CreateUserResponse userId
|
||||
--
|
||||
-- @since 1.6.14
|
||||
data JSONResponse a where
|
||||
JSONResponse :: ToJSON a => a -> JSONResponse a
|
||||
|
||||
-- | Prevents a response body from being fully evaluated before sending the
|
||||
-- request.
|
||||
--
|
||||
@ -339,39 +311,21 @@ newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
|
||||
-- | Responses to indicate some form of an error occurred.
|
||||
data ErrorResponse =
|
||||
NotFound
|
||||
-- ^ The requested resource was not found.
|
||||
-- Examples of when this occurs include when an incorrect URL is used, or @yesod-persistent@'s 'get404' doesn't find a value.
|
||||
-- HTTP status: 404.
|
||||
| InternalError !Text
|
||||
-- ^ Some sort of unexpected exception.
|
||||
-- If your application uses `throwIO` or `error` to throw an exception, this is the form it would take.
|
||||
-- HTTP status: 500.
|
||||
| InvalidArgs ![Text]
|
||||
-- ^ Indicates some sort of invalid or missing argument, like a missing query parameter or malformed JSON body.
|
||||
-- Examples Yesod functions that send this include 'requireCheckJsonBody' and @Yesod.Auth.GoogleEmail2@.
|
||||
-- HTTP status: 400.
|
||||
| InternalError Text
|
||||
| InvalidArgs [Text]
|
||||
| NotAuthenticated
|
||||
-- ^ Indicates the user is not logged in.
|
||||
-- This is thrown when 'isAuthorized' returns 'AuthenticationRequired'.
|
||||
-- HTTP code: 401.
|
||||
| PermissionDenied !Text
|
||||
-- ^ Indicates the user doesn't have permission to access the requested resource.
|
||||
-- This is thrown when 'isAuthorized' returns 'Unauthorized'.
|
||||
-- HTTP code: 403.
|
||||
| BadMethod !H.Method
|
||||
-- ^ Indicates the URL would have been valid if used with a different HTTP method (e.g. a GET was used, but only POST is handled.)
|
||||
-- HTTP code: 405.
|
||||
deriving (Show, Eq, Generic)
|
||||
instance NFData ErrorResponse
|
||||
| PermissionDenied Text
|
||||
| BadMethod H.Method
|
||||
deriving (Show, Eq, Typeable, Generic)
|
||||
instance NFData ErrorResponse where
|
||||
rnf = genericRnf
|
||||
|
||||
----- header stuff
|
||||
-- | Headers to be added to a 'Result'.
|
||||
data Header =
|
||||
AddCookie !SetCookie
|
||||
| DeleteCookie !ByteString !ByteString
|
||||
-- ^ name and path
|
||||
| Header !(CI ByteString) !ByteString
|
||||
-- ^ key and value
|
||||
AddCookie SetCookie
|
||||
| DeleteCookie ByteString ByteString
|
||||
| Header ByteString ByteString
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- FIXME In the next major version bump, let's just add strictness annotations
|
||||
@ -382,35 +336,31 @@ instance NFData Header where
|
||||
rnf (DeleteCookie x y) = x `seq` y `seq` ()
|
||||
rnf (Header x y) = x `seq` y `seq` ()
|
||||
|
||||
data Location url = Local !url | Remote !Text
|
||||
data Location url = Local url | Remote Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | A diff list that does not directly enforce uniqueness.
|
||||
-- When creating a widget Yesod will use nub to make it unique.
|
||||
newtype UniqueList x = UniqueList ([x] -> [x])
|
||||
|
||||
data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :: ![(Text, Text)] }
|
||||
data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }
|
||||
deriving (Show, Eq)
|
||||
data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }
|
||||
data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }
|
||||
deriving (Show, Eq)
|
||||
newtype Title = Title { unTitle :: Html }
|
||||
newtype Description = Description { unDescription :: Text }
|
||||
|
||||
newtype Head url = Head (HtmlUrl url)
|
||||
deriving Monoid
|
||||
instance Semigroup (Head url) where
|
||||
(<>) = mappend
|
||||
instance Semigroup (Head a)
|
||||
newtype Body url = Body (HtmlUrl url)
|
||||
deriving Monoid
|
||||
instance Semigroup (Body url) where
|
||||
(<>) = mappend
|
||||
instance Semigroup (Body a)
|
||||
|
||||
type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder
|
||||
|
||||
data GWData a = GWData
|
||||
{ gwdBody :: !(Body a)
|
||||
, gwdTitle :: !(Last Title)
|
||||
, gwdDescription :: !(Last Description)
|
||||
, gwdScripts :: !(UniqueList (Script a))
|
||||
, gwdStylesheets :: !(UniqueList (Stylesheet a))
|
||||
, gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type
|
||||
@ -418,30 +368,27 @@ data GWData a = GWData
|
||||
, gwdHead :: !(Head a)
|
||||
}
|
||||
instance Monoid (GWData a) where
|
||||
mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
mappend = (<>)
|
||||
#endif
|
||||
instance Semigroup (GWData a) where
|
||||
GWData a1 a2 a3 a4 a5 a6 a7 a8 <>
|
||||
GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData
|
||||
(mappend a1 b1)
|
||||
(mappend a2 b2)
|
||||
(mappend a3 b3)
|
||||
(mappend a4 b4)
|
||||
(mappend a5 b5)
|
||||
(unionWith mappend a6 b6)
|
||||
(mappend a7 b7)
|
||||
(mappend a8 b8)
|
||||
mempty = GWData mempty mempty mempty mempty mempty mempty mempty
|
||||
mappend (GWData a1 a2 a3 a4 a5 a6 a7)
|
||||
(GWData b1 b2 b3 b4 b5 b6 b7) = GWData
|
||||
(a1 `mappend` b1)
|
||||
(a2 `mappend` b2)
|
||||
(a3 `mappend` b3)
|
||||
(a4 `mappend` b4)
|
||||
(unionWith mappend a5 b5)
|
||||
(a6 `mappend` b6)
|
||||
(a7 `mappend` b7)
|
||||
instance Semigroup (GWData a)
|
||||
|
||||
data HandlerContents =
|
||||
HCContent !H.Status !TypedContent
|
||||
| HCError !ErrorResponse
|
||||
| HCSendFile !ContentType !FilePath !(Maybe FilePart)
|
||||
| HCRedirect !H.Status !Text
|
||||
| HCCreated !Text
|
||||
| HCWai !W.Response
|
||||
| HCWaiApp !W.Application
|
||||
HCContent H.Status !TypedContent
|
||||
| HCError ErrorResponse
|
||||
| HCSendFile ContentType FilePath (Maybe FilePart)
|
||||
| HCRedirect H.Status Text
|
||||
| HCCreated Text
|
||||
| HCWai W.Response
|
||||
| HCWaiApp W.Application
|
||||
deriving Typeable
|
||||
|
||||
instance Show HandlerContents where
|
||||
show (HCContent status (TypedContent t _)) = "HCContent " ++ show (status, t)
|
||||
@ -453,87 +400,153 @@ instance Show HandlerContents where
|
||||
show (HCWaiApp _) = "HCWaiApp"
|
||||
instance Exception HandlerContents
|
||||
|
||||
-- Instances for WidgetFor
|
||||
instance Applicative (WidgetFor site) where
|
||||
pure = WidgetFor . const . pure
|
||||
-- Instances for WidgetT
|
||||
instance Monad m => Functor (WidgetT site m) where
|
||||
fmap = liftM
|
||||
instance Monad m => Applicative (WidgetT site m) where
|
||||
pure = return
|
||||
(<*>) = ap
|
||||
instance Monad (WidgetFor site) where
|
||||
return = pure
|
||||
WidgetFor x >>= f = WidgetFor $ \wd -> do
|
||||
a <- x wd
|
||||
unWidgetFor (f a) wd
|
||||
instance MonadIO (WidgetFor site) where
|
||||
liftIO = WidgetFor . const
|
||||
-- | @since 1.6.7
|
||||
instance PrimMonad (WidgetFor site) where
|
||||
type PrimState (WidgetFor site) = PrimState IO
|
||||
primitive = liftIO . primitive
|
||||
-- | @since 1.4.38
|
||||
instance MonadUnliftIO (WidgetFor site) where
|
||||
{-# INLINE withRunInIO #-}
|
||||
withRunInIO inner = WidgetFor $ \x -> inner $ flip unWidgetFor x
|
||||
instance MonadReader (WidgetData site) (WidgetFor site) where
|
||||
ask = WidgetFor return
|
||||
local f (WidgetFor g) = WidgetFor $ g . f
|
||||
instance Monad m => Monad (WidgetT site m) where
|
||||
return a = WidgetT $ const $ return (a, mempty)
|
||||
WidgetT x >>= f = WidgetT $ \r -> do
|
||||
(a, wa) <- x r
|
||||
(b, wb) <- unWidgetT (f a) r
|
||||
return (b, wa `mappend` wb)
|
||||
instance MonadIO m => MonadIO (WidgetT site m) where
|
||||
liftIO = lift . liftIO
|
||||
instance MonadBase b m => MonadBase b (WidgetT site m) where
|
||||
liftBase = WidgetT . const . liftBase . fmap (, mempty)
|
||||
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
|
||||
#if MIN_VERSION_monad_control(1,0,0)
|
||||
type StM (WidgetT site m) a = StM m (a, GWData (Route site))
|
||||
liftBaseWith f = WidgetT $ \reader' ->
|
||||
liftBaseWith $ \runInBase ->
|
||||
fmap (\x -> (x, mempty))
|
||||
(f $ runInBase . flip unWidgetT reader')
|
||||
restoreM = WidgetT . const . restoreM
|
||||
#else
|
||||
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
|
||||
liftBaseWith f = WidgetT $ \reader' ->
|
||||
liftBaseWith $ \runInBase ->
|
||||
fmap (\x -> (x, mempty))
|
||||
(f $ fmap StW . runInBase . flip unWidgetT reader')
|
||||
restoreM (StW base) = WidgetT $ const $ restoreM base
|
||||
#endif
|
||||
instance Monad m => MonadReader site (WidgetT site m) where
|
||||
ask = WidgetT $ \hd -> return (rheSite $ handlerEnv hd, mempty)
|
||||
local f (WidgetT g) = WidgetT $ \hd -> g hd
|
||||
{ handlerEnv = (handlerEnv hd)
|
||||
{ rheSite = f $ rheSite $ handlerEnv hd
|
||||
}
|
||||
}
|
||||
|
||||
instance MonadThrow (WidgetFor site) where
|
||||
throwM = liftIO . throwM
|
||||
instance MonadTrans (WidgetT site) where
|
||||
lift = WidgetT . const . liftM (, mempty)
|
||||
instance MonadThrow m => MonadThrow (WidgetT site m) where
|
||||
throwM = lift . throwM
|
||||
|
||||
instance MonadResource (WidgetFor site) where
|
||||
liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler
|
||||
instance MonadCatch m => MonadCatch (HandlerT site m) where
|
||||
catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r
|
||||
instance MonadMask m => MonadMask (HandlerT site m) where
|
||||
mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e
|
||||
where q u (HandlerT b) = HandlerT (u . b)
|
||||
uninterruptibleMask a =
|
||||
HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e
|
||||
where q u (HandlerT b) = HandlerT (u . b)
|
||||
instance MonadCatch m => MonadCatch (WidgetT site m) where
|
||||
catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r
|
||||
instance MonadMask m => MonadMask (WidgetT site m) where
|
||||
mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e
|
||||
where q u (WidgetT b) = WidgetT (u . b)
|
||||
uninterruptibleMask a =
|
||||
WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e
|
||||
where q u (WidgetT b) = WidgetT (u . b)
|
||||
|
||||
instance MonadLogger (WidgetFor site) where
|
||||
monadLoggerLog a b c d = WidgetFor $ \wd ->
|
||||
rheLog (handlerEnv $ wdHandler wd) a b c (toLogStr d)
|
||||
instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
|
||||
liftResourceT f = WidgetT $ \hd -> liftIO $ (, mempty) <$> runInternalState f (handlerResource hd)
|
||||
|
||||
instance MonadLoggerIO (WidgetFor site) where
|
||||
askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
|
||||
instance MonadIO m => MonadLogger (WidgetT site m) where
|
||||
monadLoggerLog a b c d = WidgetT $ \hd ->
|
||||
liftIO $ (, mempty) <$> rheLog (handlerEnv hd) a b c (toLogStr d)
|
||||
|
||||
-- Instances for HandlerFor
|
||||
instance Applicative (HandlerFor site) where
|
||||
pure = HandlerFor . const . return
|
||||
#if MIN_VERSION_monad_logger(0, 3, 10)
|
||||
instance MonadIO m => MonadLoggerIO (WidgetT site m) where
|
||||
askLoggerIO = WidgetT $ \hd -> return (rheLog (handlerEnv hd), mempty)
|
||||
#endif
|
||||
|
||||
instance MonadActive m => MonadActive (WidgetT site m) where
|
||||
monadActive = lift monadActive
|
||||
instance MonadActive m => MonadActive (HandlerT site m) where
|
||||
monadActive = lift monadActive
|
||||
|
||||
instance MonadTrans (HandlerT site) where
|
||||
lift = HandlerT . const
|
||||
|
||||
-- Instances for HandlerT
|
||||
instance Monad m => Functor (HandlerT site m) where
|
||||
fmap = liftM
|
||||
instance Monad m => Applicative (HandlerT site m) where
|
||||
pure = return
|
||||
(<*>) = ap
|
||||
instance Monad (HandlerFor site) where
|
||||
return = pure
|
||||
HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r
|
||||
instance MonadIO (HandlerFor site) where
|
||||
liftIO = HandlerFor . const
|
||||
-- | @since 1.6.7
|
||||
instance PrimMonad (HandlerFor site) where
|
||||
type PrimState (HandlerFor site) = PrimState IO
|
||||
primitive = liftIO . primitive
|
||||
instance MonadReader (HandlerData site site) (HandlerFor site) where
|
||||
ask = HandlerFor return
|
||||
local f (HandlerFor g) = HandlerFor $ g . f
|
||||
instance Monad m => Monad (HandlerT site m) where
|
||||
return = HandlerT . const . return
|
||||
HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r
|
||||
instance MonadIO m => MonadIO (HandlerT site m) where
|
||||
liftIO = lift . liftIO
|
||||
instance MonadBase b m => MonadBase b (HandlerT site m) where
|
||||
liftBase = lift . liftBase
|
||||
instance Monad m => MonadReader site (HandlerT site m) where
|
||||
ask = HandlerT $ return . rheSite . handlerEnv
|
||||
local f (HandlerT g) = HandlerT $ \hd -> g hd
|
||||
{ handlerEnv = (handlerEnv hd)
|
||||
{ rheSite = f $ rheSite $ handlerEnv hd
|
||||
}
|
||||
}
|
||||
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
|
||||
-- @fork@ function is incompatible with the underlying @ResourceT@ system.
|
||||
-- Instead, if you must fork a separate thread, you should use
|
||||
-- @resourceForkIO@.
|
||||
--
|
||||
-- Using fork usually leads to an exception that says
|
||||
-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed
|
||||
-- after cleanup. Please contact the maintainers.\"
|
||||
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
|
||||
#if MIN_VERSION_monad_control(1,0,0)
|
||||
type StM (HandlerT site m) a = StM m a
|
||||
liftBaseWith f = HandlerT $ \reader' ->
|
||||
liftBaseWith $ \runInBase ->
|
||||
f $ runInBase . (\(HandlerT r) -> r reader')
|
||||
restoreM = HandlerT . const . restoreM
|
||||
#else
|
||||
data StM (HandlerT site m) a = StH (StM m a)
|
||||
liftBaseWith f = HandlerT $ \reader' ->
|
||||
liftBaseWith $ \runInBase ->
|
||||
f $ fmap StH . runInBase . (\(HandlerT r) -> r reader')
|
||||
restoreM (StH base) = HandlerT $ const $ restoreM base
|
||||
#endif
|
||||
|
||||
-- | @since 1.4.38
|
||||
instance MonadUnliftIO (HandlerFor site) where
|
||||
{-# INLINE withRunInIO #-}
|
||||
withRunInIO inner = HandlerFor $ \x -> inner $ flip unHandlerFor x
|
||||
instance MonadThrow m => MonadThrow (HandlerT site m) where
|
||||
throwM = lift . monadThrow
|
||||
|
||||
instance MonadThrow (HandlerFor site) where
|
||||
throwM = liftIO . throwM
|
||||
instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where
|
||||
liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
|
||||
|
||||
instance MonadResource (HandlerFor site) where
|
||||
liftResourceT f = HandlerFor $ runInternalState f . handlerResource
|
||||
instance MonadIO m => MonadLogger (HandlerT site m) where
|
||||
monadLoggerLog a b c d = HandlerT $ \hd ->
|
||||
liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
|
||||
|
||||
instance MonadLogger (HandlerFor site) where
|
||||
monadLoggerLog a b c d = HandlerFor $ \hd ->
|
||||
rheLog (handlerEnv hd) a b c (toLogStr d)
|
||||
|
||||
instance MonadLoggerIO (HandlerFor site) where
|
||||
askLoggerIO = HandlerFor $ \hd -> return (rheLog (handlerEnv hd))
|
||||
#if MIN_VERSION_monad_logger(0, 3, 10)
|
||||
instance MonadIO m => MonadLoggerIO (HandlerT site m) where
|
||||
askLoggerIO = HandlerT $ \hd -> return (rheLog (handlerEnv hd))
|
||||
#endif
|
||||
|
||||
instance Monoid (UniqueList x) where
|
||||
mempty = UniqueList id
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
mappend = (<>)
|
||||
#endif
|
||||
instance Semigroup (UniqueList x) where
|
||||
UniqueList x <> UniqueList y = UniqueList $ x . y
|
||||
UniqueList x `mappend` UniqueList y = UniqueList $ x . y
|
||||
instance Semigroup (UniqueList x)
|
||||
|
||||
instance IsString Content where
|
||||
fromString = flip ContentBuilder Nothing . BB.stringUtf8
|
||||
fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString
|
||||
|
||||
instance RenderRoute WaiSubsite where
|
||||
data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]
|
||||
@ -542,14 +555,6 @@ instance RenderRoute WaiSubsite where
|
||||
instance ParseRoute WaiSubsite where
|
||||
parseRoute (x, y) = Just $ WaiSubsiteRoute x y
|
||||
|
||||
instance RenderRoute WaiSubsiteWithAuth where
|
||||
data Route WaiSubsiteWithAuth = WaiSubsiteWithAuthRoute [Text] [(Text,Text)]
|
||||
deriving (Show, Eq, Read, Ord)
|
||||
renderRoute (WaiSubsiteWithAuthRoute ps qs) = (ps,qs)
|
||||
|
||||
instance ParseRoute WaiSubsiteWithAuth where
|
||||
parseRoute (x, y) = Just $ WaiSubsiteWithAuthRoute x y
|
||||
|
||||
data Logger = Logger
|
||||
{ loggerSet :: !LoggerSet
|
||||
, loggerDate :: !DateCacheGetter
|
||||
@ -557,41 +562,3 @@ data Logger = Logger
|
||||
|
||||
loggerPutStr :: Logger -> LogStr -> IO ()
|
||||
loggerPutStr (Logger ls _) = pushLogStr ls
|
||||
|
||||
-- | A handler monad for subsite
|
||||
--
|
||||
-- @since 1.6.0
|
||||
newtype SubHandlerFor sub master a = SubHandlerFor
|
||||
{ unSubHandlerFor :: HandlerData sub master -> IO a
|
||||
}
|
||||
deriving Functor
|
||||
|
||||
instance Applicative (SubHandlerFor child master) where
|
||||
pure = SubHandlerFor . const . return
|
||||
(<*>) = ap
|
||||
instance Monad (SubHandlerFor child master) where
|
||||
return = pure
|
||||
SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r
|
||||
instance MonadIO (SubHandlerFor child master) where
|
||||
liftIO = SubHandlerFor . const
|
||||
instance MonadReader (HandlerData child master) (SubHandlerFor child master) where
|
||||
ask = SubHandlerFor return
|
||||
local f (SubHandlerFor g) = SubHandlerFor $ g . f
|
||||
|
||||
-- | @since 1.4.38
|
||||
instance MonadUnliftIO (SubHandlerFor child master) where
|
||||
{-# INLINE withRunInIO #-}
|
||||
withRunInIO inner = SubHandlerFor $ \x -> inner $ flip unSubHandlerFor x
|
||||
|
||||
instance MonadThrow (SubHandlerFor child master) where
|
||||
throwM = liftIO . throwM
|
||||
|
||||
instance MonadResource (SubHandlerFor child master) where
|
||||
liftResourceT f = SubHandlerFor $ runInternalState f . handlerResource
|
||||
|
||||
instance MonadLogger (SubHandlerFor child master) where
|
||||
monadLoggerLog a b c d = SubHandlerFor $ \sd ->
|
||||
rheLog (handlerEnv sd) a b c (toLogStr d)
|
||||
|
||||
instance MonadLoggerIO (SubHandlerFor child master) where
|
||||
askLoggerIO = SubHandlerFor $ return . rheLog . handlerEnv
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- | This is designed to be used as
|
||||
--
|
||||
-- > import qualified Yesod.Core.Unsafe as Unsafe
|
||||
-- > qualified import Yesod.Core.Unsafe as Unsafe
|
||||
--
|
||||
-- This serves as a reminder that the functions are unsafe to use in many situations.
|
||||
module Yesod.Core.Unsafe (runFakeHandler, fakeHandlerGetLogger) where
|
||||
@ -9,16 +10,16 @@ import Yesod.Core.Internal.Run (runFakeHandler)
|
||||
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Class.Yesod
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Data.Monoid (mempty, mappend)
|
||||
#endif
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
|
||||
-- | designed to be used as
|
||||
--
|
||||
-- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
|
||||
fakeHandlerGetLogger :: (Yesod site, MonadIO m)
|
||||
=> (site -> Logger)
|
||||
-> site
|
||||
-> HandlerFor site a
|
||||
-> m a
|
||||
=> (site -> Logger) -> site -> HandlerT site IO a -> m a
|
||||
fakeHandlerGetLogger getLogger app f =
|
||||
runFakeHandler mempty getLogger app f
|
||||
>>= either (error . ("runFakeHandler issue: " `mappend`) . show)
|
||||
@ -8,14 +8,12 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
|
||||
-- generator, allowing you to create truly modular HTML components.
|
||||
module Yesod.Core.Widget
|
||||
( -- * Datatype
|
||||
WidgetT
|
||||
, WidgetFor
|
||||
, PageContent (..)
|
||||
-- * Special Hamlet quasiquoter/TH for Widgets
|
||||
, whamlet
|
||||
@ -31,12 +29,6 @@ module Yesod.Core.Widget
|
||||
-- ** Head of page
|
||||
, setTitle
|
||||
, setTitleI
|
||||
, setDescription
|
||||
, setDescriptionI
|
||||
, setDescriptionIdemp
|
||||
, setDescriptionIdempI
|
||||
, setOGType
|
||||
, setOGImage
|
||||
-- ** CSS
|
||||
, addStylesheet
|
||||
, addStylesheetAttrs
|
||||
@ -51,6 +43,7 @@ module Yesod.Core.Widget
|
||||
, addScriptRemoteAttrs
|
||||
, addScriptEither
|
||||
-- * Subsites
|
||||
, widgetToParentWidget
|
||||
, handlerToWidget
|
||||
-- * Internal
|
||||
, whamletFileWithSettings
|
||||
@ -64,9 +57,13 @@ import Text.Cassius
|
||||
import Text.Julius
|
||||
import Yesod.Routes.Class
|
||||
import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Text.Shakespeare.I18N (RenderMessage)
|
||||
import Data.Text (Text)
|
||||
import Data.Kind (Type)
|
||||
import qualified Data.Map as Map
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
|
||||
@ -75,14 +72,10 @@ import qualified Text.Hamlet as NP
|
||||
import Data.Text.Lazy.Builder (fromLazyText)
|
||||
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TB
|
||||
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Class.Handler
|
||||
|
||||
type WidgetT site (m :: Type -> Type) = WidgetFor site
|
||||
{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
|
||||
|
||||
preEscapedLazyText :: TL.Text -> Html
|
||||
preEscapedLazyText = preEscapedToMarkup
|
||||
|
||||
@ -90,32 +83,23 @@ class ToWidget site a where
|
||||
toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
|
||||
|
||||
instance render ~ RY site => ToWidget site (render -> Html) where
|
||||
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty mempty
|
||||
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
|
||||
instance render ~ RY site => ToWidget site (render -> Css) where
|
||||
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
|
||||
instance ToWidget site Css where
|
||||
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x
|
||||
instance render ~ RY site => ToWidget site (render -> CssBuilder) where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
|
||||
instance ToWidget site CssBuilder where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
|
||||
instance render ~ RY site => ToWidget site (render -> Javascript) where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just x) mempty
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
|
||||
instance ToWidget site Javascript where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just $ const x) mempty
|
||||
instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where
|
||||
toWidget = liftWidget
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty
|
||||
instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where
|
||||
toWidget = liftWidgetT
|
||||
instance ToWidget site Html where
|
||||
toWidget = toWidget . const
|
||||
-- | @since 1.4.28
|
||||
instance ToWidget site Text where
|
||||
toWidget = toWidget . toHtml
|
||||
-- | @since 1.4.28
|
||||
instance ToWidget site TL.Text where
|
||||
toWidget = toWidget . toHtml
|
||||
-- | @since 1.4.28
|
||||
instance ToWidget site TB.Builder where
|
||||
toWidget = toWidget . toHtml
|
||||
|
||||
-- | Allows adding some CSS to the page with a specific media type.
|
||||
--
|
||||
@ -133,9 +117,9 @@ instance render ~ RY site => ToWidgetMedia site (render -> Css) where
|
||||
instance ToWidgetMedia site Css where
|
||||
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x
|
||||
instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
|
||||
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
|
||||
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
|
||||
instance ToWidgetMedia site CssBuilder where
|
||||
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
|
||||
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
|
||||
|
||||
class ToWidgetBody site a where
|
||||
toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
|
||||
@ -153,7 +137,7 @@ class ToWidgetHead site a where
|
||||
toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
|
||||
|
||||
instance render ~ RY site => ToWidgetHead site (render -> Html) where
|
||||
toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty mempty . Head
|
||||
toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
|
||||
instance render ~ RY site => ToWidgetHead site (render -> Css) where
|
||||
toWidgetHead = toWidget
|
||||
instance ToWidgetHead site Css where
|
||||
@ -169,133 +153,18 @@ instance ToWidgetHead site Javascript where
|
||||
instance ToWidgetHead site Html where
|
||||
toWidgetHead = toWidgetHead . const
|
||||
|
||||
-- | Set the page title.
|
||||
--
|
||||
-- Calling @setTitle@ or @setTitleI@ multiple times overrides previously set
|
||||
-- values.
|
||||
--
|
||||
-- SEO Notes:
|
||||
--
|
||||
-- * Title tags are the second most important on-page factor for SEO, after
|
||||
-- content
|
||||
-- * Every page should have a unique title tag
|
||||
-- * Start your title tag with your main targeted keyword
|
||||
-- * Don't stuff your keywords
|
||||
-- * Google typically shows 55-64 characters, so aim to keep your title
|
||||
-- length under 60 characters
|
||||
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
||||
-- set values.
|
||||
setTitle :: MonadWidget m => Html -> m ()
|
||||
setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty
|
||||
setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Set the localised page title.
|
||||
--
|
||||
-- n.b. See comments for @setTitle@
|
||||
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
||||
-- set values.
|
||||
setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
|
||||
setTitleI msg = do
|
||||
mr <- getMessageRender
|
||||
setTitle $ toHtml $ mr msg
|
||||
|
||||
-- | Add description meta tag to the head of the page
|
||||
--
|
||||
-- Google does not use the description tag as a ranking signal, but the
|
||||
-- contents of this tag will likely affect your click-through rate since it
|
||||
-- shows up in search results.
|
||||
--
|
||||
-- The average length of the description shown in Google's search results is
|
||||
-- about 160 characters on desktop, and about 130 characters on mobile, at time
|
||||
-- of writing.
|
||||
--
|
||||
-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
|
||||
--
|
||||
-- @since 1.6.18
|
||||
setDescription :: MonadWidget m => Text -> m ()
|
||||
setDescription description =
|
||||
toWidgetHead $ [hamlet|<meta name=description content=#{description}>|]
|
||||
|
||||
{-# WARNING setDescription
|
||||
[ "setDescription is not idempotent; we recommend setDescriptionIdemp instead"
|
||||
, "Multiple calls to setDescription will insert multiple meta tags in the page head."
|
||||
, "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \
|
||||
\may need to change your layout to include pageDescription."
|
||||
]
|
||||
#-}
|
||||
|
||||
-- | Add translated description meta tag to the head of the page
|
||||
--
|
||||
-- n.b. See comments for @setDescription@.
|
||||
--
|
||||
-- @since 1.6.18
|
||||
setDescriptionI
|
||||
:: (MonadWidget m, RenderMessage (HandlerSite m) msg)
|
||||
=> msg -> m ()
|
||||
setDescriptionI msg = do
|
||||
mr <- getMessageRender
|
||||
toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|]
|
||||
|
||||
{-# WARNING setDescriptionI
|
||||
[ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead"
|
||||
, "Multiple calls to setDescriptionI will insert multiple meta tags in the page head."
|
||||
, "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \
|
||||
\may need to change your layout to include pageDescription."
|
||||
]
|
||||
#-}
|
||||
|
||||
-- | Add description meta tag to the head of the page
|
||||
--
|
||||
-- Google does not use the description tag as a ranking signal, but the
|
||||
-- contents of this tag will likely affect your click-through rate since it
|
||||
-- shows up in search results.
|
||||
--
|
||||
-- The average length of the description shown in Google's search results is
|
||||
-- about 160 characters on desktop, and about 130 characters on mobile, at time
|
||||
-- of writing.
|
||||
--
|
||||
-- Unlike 'setDescription', this version is *idempotent* - calling it multiple
|
||||
-- times will result in only a single description meta tag in the head.
|
||||
--
|
||||
-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
|
||||
--
|
||||
-- @since 1.6.23
|
||||
setDescriptionIdemp :: MonadWidget m => Text -> m ()
|
||||
setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Add translated description meta tag to the head of the page
|
||||
--
|
||||
-- n.b. See comments for @setDescriptionIdemp@.
|
||||
--
|
||||
-- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple
|
||||
-- times will result in only a single description meta tag in the head.
|
||||
--
|
||||
-- @since 1.6.23
|
||||
setDescriptionIdempI
|
||||
:: (MonadWidget m, RenderMessage (HandlerSite m) msg)
|
||||
=> msg -> m ()
|
||||
setDescriptionIdempI msg = do
|
||||
mr <- getMessageRender
|
||||
setDescriptionIdemp $ mr msg
|
||||
|
||||
-- | Add OpenGraph type meta tag to the head of the page
|
||||
--
|
||||
-- See all available OG types here: https://ogp.me/#types
|
||||
--
|
||||
-- @since 1.6.18
|
||||
setOGType :: MonadWidget m => Text -> m ()
|
||||
setOGType a = toWidgetHead $ [hamlet|<meta property="og:type" content=#{a}>|]
|
||||
|
||||
-- | Add OpenGraph image meta tag to the head of the page
|
||||
--
|
||||
-- Best practices:
|
||||
--
|
||||
-- * Use custom images for shareable pages, e.g., homepage, articles, etc.
|
||||
-- * Use your logo or any other branded image for the rest of your pages.
|
||||
-- * Use images with a 1.91:1 ratio and minimum recommended dimensions of
|
||||
-- 1200x630 for optimal clarity across all devices.
|
||||
--
|
||||
-- Source: https://ahrefs.com/blog/open-graph-meta-tags/
|
||||
--
|
||||
-- @since 1.6.18
|
||||
setOGImage :: MonadWidget m => Text -> m ()
|
||||
setOGImage a = toWidgetHead $ [hamlet|<meta property="og:image" content=#{a}>|]
|
||||
|
||||
-- | Link to the specified local stylesheet.
|
||||
addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
|
||||
addStylesheet = flip addStylesheetAttrs []
|
||||
@ -305,7 +174,7 @@ addStylesheetAttrs :: MonadWidget m
|
||||
=> Route (HandlerSite m)
|
||||
-> [(Text, Text)]
|
||||
-> m ()
|
||||
addStylesheetAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
|
||||
addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemote :: MonadWidget m => Text -> m ()
|
||||
@ -313,7 +182,7 @@ addStylesheetRemote = flip addStylesheetRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
|
||||
addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
|
||||
addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
|
||||
|
||||
addStylesheetEither :: MonadWidget m
|
||||
=> Either (Route (HandlerSite m)) Text
|
||||
@ -331,7 +200,7 @@ addScript = flip addScriptAttrs []
|
||||
|
||||
-- | Link to the specified local script.
|
||||
addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()
|
||||
addScriptAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
|
||||
addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemote :: MonadWidget m => Text -> m ()
|
||||
@ -339,7 +208,7 @@ addScriptRemote = flip addScriptRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
|
||||
addScriptRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
|
||||
addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
|
||||
|
||||
whamlet :: QuasiQuoter
|
||||
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
|
||||
@ -389,10 +258,45 @@ ihamletToHtml ih = do
|
||||
return $ ih (toHtml . mrender) urender
|
||||
|
||||
tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
|
||||
tell = liftWidget . tellWidget
|
||||
tell w = liftWidgetT $ WidgetT $ const $ return ((), w)
|
||||
|
||||
toUnique :: x -> UniqueList x
|
||||
toUnique = UniqueList . (:)
|
||||
|
||||
handlerToWidget :: HandlerFor site a -> WidgetFor site a
|
||||
handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler
|
||||
handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a
|
||||
handlerToWidget (HandlerT f) = WidgetT $ liftM (, mempty) . f
|
||||
|
||||
widgetToParentWidget :: MonadIO m
|
||||
=> WidgetT child IO a
|
||||
-> HandlerT child (HandlerT parent m) (WidgetT parent m a)
|
||||
widgetToParentWidget (WidgetT f) = HandlerT $ \hd -> do
|
||||
(a, gwd) <- liftIO $ f hd { handlerToParent = const () }
|
||||
return $ WidgetT $ const $ return (a, liftGWD (handlerToParent hd) gwd)
|
||||
|
||||
liftGWD :: (child -> parent) -> GWData child -> GWData parent
|
||||
liftGWD tp gwd = GWData
|
||||
{ gwdBody = fixBody $ gwdBody gwd
|
||||
, gwdTitle = gwdTitle gwd
|
||||
, gwdScripts = fixUnique fixScript $ gwdScripts gwd
|
||||
, gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd
|
||||
, gwdCss = fixCss <$> gwdCss gwd
|
||||
, gwdJavascript = fixJS <$> gwdJavascript gwd
|
||||
, gwdHead = fixHead $ gwdHead gwd
|
||||
}
|
||||
where
|
||||
fixRender f route = f (tp route)
|
||||
|
||||
fixBody (Body h) = Body $ h . fixRender
|
||||
fixHead (Head h) = Head $ h . fixRender
|
||||
|
||||
fixUnique go (UniqueList f) = UniqueList (map go (f []) ++)
|
||||
|
||||
fixScript (Script loc attrs) = Script (fixLoc loc) attrs
|
||||
fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs
|
||||
|
||||
fixLoc (Local url) = Local $ tp url
|
||||
fixLoc (Remote t) = Remote t
|
||||
|
||||
fixCss f = f . fixRender
|
||||
|
||||
fixJS f = f . fixRender
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
|
||||
module Yesod.Routes.Parse
|
||||
@ -9,13 +10,10 @@ module Yesod.Routes.Parse
|
||||
, parseType
|
||||
, parseTypeTree
|
||||
, TypeTree (..)
|
||||
, dropBracket
|
||||
, nameToType
|
||||
, isTvar
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Char (isUpper, isLower, isSpace)
|
||||
import Data.Char (isUpper)
|
||||
import Language.Haskell.TH.Quote
|
||||
import qualified System.IO as SIO
|
||||
import Yesod.Routes.TH
|
||||
@ -36,15 +34,9 @@ parseRoutes = QuasiQuoter { quoteExp = x }
|
||||
[] -> lift res
|
||||
z -> error $ unlines $ "Overlapping routes: " : map show z
|
||||
|
||||
-- | Same as 'parseRoutes', but uses an external file instead of quasiquotation.
|
||||
--
|
||||
-- The recommended file extension is @.yesodroutes@.
|
||||
parseRoutesFile :: FilePath -> Q Exp
|
||||
parseRoutesFile = parseRoutesFileWith parseRoutes
|
||||
|
||||
-- | Same as 'parseRoutesNoCheck', but uses an external file instead of quasiquotation.
|
||||
--
|
||||
-- The recommended file extension is @.yesodroutes@.
|
||||
parseRoutesFileNoCheck :: FilePath -> Q Exp
|
||||
parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck
|
||||
|
||||
@ -71,7 +63,7 @@ parseRoutesNoCheck = QuasiQuoter
|
||||
-- invalid input.
|
||||
resourcesFromString :: String -> [ResourceTree String]
|
||||
resourcesFromString =
|
||||
fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r')
|
||||
fst . parse 0 . filter (not . all (== ' ')) . lines
|
||||
where
|
||||
parse _ [] = ([], [])
|
||||
parse indent (thisLine:otherLines)
|
||||
@ -94,7 +86,7 @@ resourcesFromString =
|
||||
spaces = takeWhile (== ' ') thisLine
|
||||
(others, remainder) = parse indent otherLines'
|
||||
(this, otherLines') =
|
||||
case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of
|
||||
case takeWhile (not . isPrefixOf "--") $ words thisLine of
|
||||
(pattern:rest0)
|
||||
| Just (constr:rest) <- stripColonLast rest0
|
||||
, Just attrs <- mapM parseAttr rest ->
|
||||
@ -110,26 +102,6 @@ resourcesFromString =
|
||||
[] -> (id, otherLines)
|
||||
_ -> error $ "Invalid resource line: " ++ thisLine
|
||||
|
||||
-- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive).
|
||||
splitSpaces :: String -> [String]
|
||||
splitSpaces "" = []
|
||||
splitSpaces str =
|
||||
let (rest, piece) = parse $ dropWhile isSpace str in
|
||||
piece:(splitSpaces rest)
|
||||
|
||||
where
|
||||
parse :: String -> ( String, String)
|
||||
parse ('{':s) = fmap ('{':) $ parseBracket s
|
||||
parse (c:s) | isSpace c = (s, [])
|
||||
parse (c:s) = fmap (c:) $ parse s
|
||||
parse "" = ("", "")
|
||||
|
||||
parseBracket :: String -> ( String, String)
|
||||
parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str
|
||||
parseBracket ('}':s) = fmap ('}':) $ parse s
|
||||
parseBracket (c:s) = fmap (c:) $ parseBracket s
|
||||
parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str
|
||||
|
||||
piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool)
|
||||
piecesFromStringCheck s0 =
|
||||
(pieces, mmulti, check)
|
||||
@ -209,7 +181,7 @@ parseTypeTree :: String -> Maybe TypeTree
|
||||
parseTypeTree orig =
|
||||
toTypeTree pieces
|
||||
where
|
||||
pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig
|
||||
pieces = filter (not . null) $ splitOn '-' $ addDashes orig
|
||||
addDashes [] = []
|
||||
addDashes (x:xs) =
|
||||
front $ addDashes xs
|
||||
@ -222,7 +194,7 @@ parseTypeTree orig =
|
||||
_:y -> x : splitOn c y
|
||||
[] -> [x]
|
||||
where
|
||||
(x, y') = break c s
|
||||
(x, y') = break (== c) s
|
||||
|
||||
data TypeTree = TTTerm String
|
||||
| TTApp TypeTree TypeTree
|
||||
@ -260,23 +232,14 @@ toTypeTree orig = do
|
||||
gos' (front . (t:)) xs'
|
||||
|
||||
ttToType :: TypeTree -> Type
|
||||
ttToType (TTTerm s) = nameToType s
|
||||
ttToType (TTTerm s) = ConT $ mkName s
|
||||
ttToType (TTApp x y) = ttToType x `AppT` ttToType y
|
||||
ttToType (TTList t) = ListT `AppT` ttToType t
|
||||
|
||||
nameToType :: String -> Type
|
||||
nameToType t = if isTvar t
|
||||
then VarT $ mkName t
|
||||
else ConT $ mkName t
|
||||
|
||||
isTvar :: String -> Bool
|
||||
isTvar (h:_) = isLower h
|
||||
isTvar _ = False
|
||||
|
||||
pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
|
||||
pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)
|
||||
pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652
|
||||
pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x)
|
||||
pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
|
||||
pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652
|
||||
pieceFromString ('#':x) = Right $ (True, Dynamic x)
|
||||
|
||||
pieceFromString ('*':'!':x) = Left (False, x)
|
||||
pieceFromString ('+':'!':x) = Left (False, x)
|
||||
@ -289,19 +252,3 @@ pieceFromString ('+':x) = Left (True, x)
|
||||
|
||||
pieceFromString ('!':x) = Right $ (False, Static x)
|
||||
pieceFromString x = Right $ (True, Static x)
|
||||
|
||||
dropBracket :: String -> String
|
||||
dropBracket str@('{':x) = case break (== '}') x of
|
||||
(s, "}") -> s
|
||||
_ -> error $ "Unclosed bracket ('{'): " ++ str
|
||||
dropBracket x = x
|
||||
|
||||
-- | If this line ends with a backslash, concatenate it together with the next line.
|
||||
--
|
||||
-- @since 1.6.8
|
||||
lineContinuations :: String -> [String] -> [String]
|
||||
lineContinuations this [] = [this]
|
||||
lineContinuations this below@(next:rest) = case unsnoc this of
|
||||
Just (this', '\\') -> (this'++next):rest
|
||||
_ -> this:below
|
||||
where unsnoc s = if null s then Nothing else Just (init s, last s)
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}
|
||||
module Yesod.Routes.TH.Dispatch
|
||||
( MkDispatchSettings (..)
|
||||
@ -74,7 +73,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
|
||||
handlePiece (Static str) = return (LitP $ StringL str, Nothing)
|
||||
handlePiece (Dynamic _) = do
|
||||
x <- newName "dyn"
|
||||
let pat = ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x])
|
||||
let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])
|
||||
return (pat, Just $ VarE x)
|
||||
|
||||
handlePieces :: [Piece a] -> Q ([Pat], [Exp])
|
||||
@ -87,7 +86,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
|
||||
mkPathPat final =
|
||||
foldr addPat final
|
||||
where
|
||||
addPat x y = conPCompat '(:) [x, y]
|
||||
addPat x y = ConP '(:) [x, y]
|
||||
|
||||
go :: SDC -> ResourceTree a -> Q Clause
|
||||
go sdc (ResourceParent name _check pieces children) = do
|
||||
@ -125,11 +124,11 @@ mkDispatchClause MkDispatchSettings {..} resources = do
|
||||
Methods multi methods -> do
|
||||
(finalPat, mfinalE) <-
|
||||
case multi of
|
||||
Nothing -> return (conPCompat '[] [], Nothing)
|
||||
Nothing -> return (ConP '[] [], Nothing)
|
||||
Just _ -> do
|
||||
multiName <- newName "multi"
|
||||
let pat = ViewP (VarE 'fromPathMultiPiece)
|
||||
(conPCompat 'Just [VarP multiName])
|
||||
(ConP 'Just [VarP multiName])
|
||||
return (pat, Just $ VarE multiName)
|
||||
|
||||
let dynsMulti =
|
||||
@ -201,10 +200,3 @@ mkDispatchClause MkDispatchSettings {..} resources = do
|
||||
defaultGetHandler :: Maybe String -> String -> Q Exp
|
||||
defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s
|
||||
defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s
|
||||
|
||||
conPCompat :: Name -> [Pat] -> Pat
|
||||
conPCompat n pats = ConP n
|
||||
#if MIN_VERSION_template_haskell(2,18,0)
|
||||
[]
|
||||
#endif
|
||||
pats
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Routes.TH.ParseRoute
|
||||
( -- ** ParseRoute
|
||||
@ -10,8 +11,8 @@ import Data.Text (Text)
|
||||
import Yesod.Routes.Class
|
||||
import Yesod.Routes.TH.Dispatch
|
||||
|
||||
mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
|
||||
mkParseRouteInstance cxt typ ress = do
|
||||
mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
|
||||
mkParseRouteInstance typ ress = do
|
||||
cls <- mkDispatchClause
|
||||
MkDispatchSettings
|
||||
{ mdsRunHandler = [|\_ _ x _ -> x|]
|
||||
@ -27,7 +28,7 @@ mkParseRouteInstance cxt typ ress = do
|
||||
(map removeMethods ress)
|
||||
helper <- newName "helper"
|
||||
fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]
|
||||
return $ instanceD cxt (ConT ''ParseRoute `AppT` typ)
|
||||
return $ instanceD [] (ConT ''ParseRoute `AppT` typ)
|
||||
[ FunD 'parseRoute $ return $ Clause
|
||||
[]
|
||||
(NormalB $ fixer `AppE` VarE helper)
|
||||
@ -44,4 +45,8 @@ mkParseRouteInstance cxt typ ress = do
|
||||
fixDispatch x = x
|
||||
|
||||
instanceD :: Cxt -> Type -> [Dec] -> Dec
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
instanceD = InstanceD Nothing
|
||||
#else
|
||||
instanceD = InstanceD
|
||||
#endif
|
||||
181
yesod-core/Yesod/Routes/TH/RenderRoute.hs
Normal file
181
yesod-core/Yesod/Routes/TH/RenderRoute.hs
Normal file
@ -0,0 +1,181 @@
|
||||
{-# LANGUAGE TemplateHaskell, CPP #-}
|
||||
module Yesod.Routes.TH.RenderRoute
|
||||
( -- ** RenderRoute
|
||||
mkRenderRouteInstance
|
||||
, mkRenderRouteInstance'
|
||||
, mkRouteCons
|
||||
, mkRenderRouteClauses
|
||||
) where
|
||||
|
||||
import Yesod.Routes.TH.Types
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
import Language.Haskell.TH (conT)
|
||||
#endif
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Maybe (maybeToList)
|
||||
import Control.Monad (replicateM)
|
||||
import Data.Text (pack)
|
||||
import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
|
||||
import Yesod.Routes.Class
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>))
|
||||
import Data.Monoid (mconcat)
|
||||
#endif
|
||||
|
||||
-- | Generate the constructors of a route data type.
|
||||
mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])
|
||||
mkRouteCons rttypes =
|
||||
mconcat <$> mapM mkRouteCon rttypes
|
||||
where
|
||||
mkRouteCon (ResourceLeaf res) =
|
||||
return ([con], [])
|
||||
where
|
||||
con = NormalC (mkName $ resourceName res)
|
||||
$ map (\x -> (notStrict, x))
|
||||
$ concat [singles, multi, sub]
|
||||
singles = concatMap toSingle $ resourcePieces res
|
||||
toSingle Static{} = []
|
||||
toSingle (Dynamic typ) = [typ]
|
||||
|
||||
multi = maybeToList $ resourceMulti res
|
||||
|
||||
sub =
|
||||
case resourceDispatch res of
|
||||
Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
|
||||
_ -> []
|
||||
|
||||
mkRouteCon (ResourceParent name _check pieces children) = do
|
||||
(cons, decs) <- mkRouteCons children
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]
|
||||
#else
|
||||
let dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]
|
||||
#endif
|
||||
return ([con], dec : decs)
|
||||
where
|
||||
con = NormalC (mkName name)
|
||||
$ map (\x -> (notStrict, x))
|
||||
$ singles ++ [ConT $ mkName name]
|
||||
|
||||
singles = concatMap toSingle pieces
|
||||
toSingle Static{} = []
|
||||
toSingle (Dynamic typ) = [typ]
|
||||
|
||||
-- | Clauses for the 'renderRoute' method.
|
||||
mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]
|
||||
mkRenderRouteClauses =
|
||||
mapM go
|
||||
where
|
||||
isDynamic Dynamic{} = True
|
||||
isDynamic _ = False
|
||||
|
||||
go (ResourceParent name _check pieces children) = do
|
||||
let cnt = length $ filter isDynamic pieces
|
||||
dyns <- replicateM cnt $ newName "dyn"
|
||||
child <- newName "child"
|
||||
let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]
|
||||
|
||||
pack' <- [|pack|]
|
||||
tsp <- [|toPathPiece|]
|
||||
let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns
|
||||
|
||||
childRender <- newName "childRender"
|
||||
let rr = VarE childRender
|
||||
childClauses <- mkRenderRouteClauses children
|
||||
|
||||
a <- newName "a"
|
||||
b <- newName "b"
|
||||
|
||||
colon <- [|(:)|]
|
||||
let cons y ys = InfixE (Just y) colon (Just ys)
|
||||
let pieces' = foldr cons (VarE a) piecesSingle
|
||||
|
||||
let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)
|
||||
|
||||
return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
|
||||
|
||||
go (ResourceLeaf res) = do
|
||||
let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
|
||||
dyns <- replicateM cnt $ newName "dyn"
|
||||
sub <-
|
||||
case resourceDispatch res of
|
||||
Subsite{} -> return <$> newName "sub"
|
||||
_ -> return []
|
||||
let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
|
||||
|
||||
pack' <- [|pack|]
|
||||
tsp <- [|toPathPiece|]
|
||||
let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns
|
||||
|
||||
piecesMulti <-
|
||||
case resourceMulti res of
|
||||
Nothing -> return $ ListE []
|
||||
Just{} -> do
|
||||
tmp <- [|toPathMultiPiece|]
|
||||
return $ tmp `AppE` VarE (last dyns)
|
||||
|
||||
body <-
|
||||
case sub of
|
||||
[x] -> do
|
||||
rr <- [|renderRoute|]
|
||||
a <- newName "a"
|
||||
b <- newName "b"
|
||||
|
||||
colon <- [|(:)|]
|
||||
let cons y ys = InfixE (Just y) colon (Just ys)
|
||||
let pieces = foldr cons (VarE a) piecesSingle
|
||||
|
||||
return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
|
||||
_ -> do
|
||||
colon <- [|(:)|]
|
||||
let cons a b = InfixE (Just a) colon (Just b)
|
||||
return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]
|
||||
|
||||
return $ Clause [pat] (NormalB body) []
|
||||
|
||||
mkPieces _ _ [] _ = []
|
||||
mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns
|
||||
mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns
|
||||
mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120"
|
||||
|
||||
-- | Generate the 'RenderRoute' instance.
|
||||
--
|
||||
-- This includes both the 'Route' associated type and the
|
||||
-- 'renderRoute' method. This function uses both 'mkRouteCons' and
|
||||
-- 'mkRenderRouteClasses'.
|
||||
mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec]
|
||||
mkRenderRouteInstance = mkRenderRouteInstance' []
|
||||
|
||||
-- | A more general version of 'mkRenderRouteInstance' which takes an
|
||||
-- additional context.
|
||||
|
||||
mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
|
||||
mkRenderRouteInstance' cxt typ ress = do
|
||||
cls <- mkRenderRouteClauses ress
|
||||
(cons, decs) <- mkRouteCons ress
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes
|
||||
#else
|
||||
let did = DataInstD [] ''Route [typ] cons clazzes
|
||||
#endif
|
||||
return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)
|
||||
[ did
|
||||
, FunD (mkName "renderRoute") cls
|
||||
] : decs
|
||||
where
|
||||
clazzes = [''Show, ''Eq, ''Read]
|
||||
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
notStrict :: Bang
|
||||
notStrict = Bang NoSourceUnpackedness NoSourceStrictness
|
||||
#else
|
||||
notStrict :: Strict
|
||||
notStrict = NotStrict
|
||||
#endif
|
||||
|
||||
instanceD :: Cxt -> Type -> [Dec] -> Dec
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
instanceD = InstanceD Nothing
|
||||
#else
|
||||
instanceD = InstanceD
|
||||
#endif
|
||||
@ -10,11 +10,14 @@ import Yesod.Routes.Class
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Set (fromList)
|
||||
import Data.Text (pack)
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
|
||||
mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
|
||||
mkRouteAttrsInstance cxt typ ress = do
|
||||
mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
|
||||
mkRouteAttrsInstance typ ress = do
|
||||
clauses <- mapM (goTree id) ress
|
||||
return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)
|
||||
return $ instanceD [] (ConT ''RouteAttrs `AppT` typ)
|
||||
[ FunD 'routeAttrs $ concat clauses
|
||||
]
|
||||
|
||||
@ -27,11 +30,7 @@ goTree front (ResourceParent name _check pieces trees) =
|
||||
toIgnore = length $ filter isDynamic pieces
|
||||
isDynamic Dynamic{} = True
|
||||
isDynamic Static{} = False
|
||||
front' = front . ConP (mkName name)
|
||||
#if MIN_VERSION_template_haskell(2,18,0)
|
||||
[]
|
||||
#endif
|
||||
. ignored
|
||||
front' = front . ConP (mkName name) . ignored
|
||||
|
||||
goRes :: (Pat -> Pat) -> Resource a -> Q Clause
|
||||
goRes front Resource {..} =
|
||||
@ -43,4 +42,8 @@ goRes front Resource {..} =
|
||||
toText s = VarE 'pack `AppE` LitE (StringL s)
|
||||
|
||||
instanceD :: Cxt -> Type -> [Dec] -> Dec
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
instanceD = InstanceD Nothing
|
||||
#else
|
||||
instanceD = InstanceD
|
||||
#endif
|
||||
@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- | Warning! This module is considered internal and may have breaking changes
|
||||
module Yesod.Routes.TH.Types
|
||||
( -- * Data types
|
||||
@ -21,7 +21,7 @@ import Language.Haskell.TH.Syntax
|
||||
data ResourceTree typ
|
||||
= ResourceLeaf (Resource typ)
|
||||
| ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ]
|
||||
deriving (Lift, Show, Functor)
|
||||
deriving Functor
|
||||
|
||||
resourceTreePieces :: ResourceTree typ -> [Piece typ]
|
||||
resourceTreePieces (ResourceLeaf r) = resourcePieces r
|
||||
@ -31,6 +31,10 @@ resourceTreeName :: ResourceTree typ -> String
|
||||
resourceTreeName (ResourceLeaf r) = resourceName r
|
||||
resourceTreeName (ResourceParent x _ _ _) = x
|
||||
|
||||
instance Lift t => Lift (ResourceTree t) where
|
||||
lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]
|
||||
lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|]
|
||||
|
||||
data Resource typ = Resource
|
||||
{ resourceName :: String
|
||||
, resourcePieces :: [Piece typ]
|
||||
@ -38,17 +42,24 @@ data Resource typ = Resource
|
||||
, resourceAttrs :: [String]
|
||||
, resourceCheck :: CheckOverlap
|
||||
}
|
||||
deriving (Lift, Show, Functor)
|
||||
deriving (Show, Functor)
|
||||
|
||||
type CheckOverlap = Bool
|
||||
|
||||
instance Lift t => Lift (Resource t) where
|
||||
lift (Resource a b c d e) = [|Resource a b c d e|]
|
||||
|
||||
data Piece typ = Static String | Dynamic typ
|
||||
deriving (Lift, Show)
|
||||
deriving Show
|
||||
|
||||
instance Functor Piece where
|
||||
fmap _ (Static s) = Static s
|
||||
fmap f (Dynamic t) = Dynamic (f t)
|
||||
|
||||
instance Lift t => Lift (Piece t) where
|
||||
lift (Static s) = [|Static $(lift s)|]
|
||||
lift (Dynamic t) = [|Dynamic $(lift t)|]
|
||||
|
||||
data Dispatch typ =
|
||||
Methods
|
||||
{ methodsMulti :: Maybe typ -- ^ type of the multi piece at the end
|
||||
@ -58,12 +69,17 @@ data Dispatch typ =
|
||||
{ subsiteType :: typ
|
||||
, subsiteFunc :: String
|
||||
}
|
||||
deriving (Lift, Show)
|
||||
deriving Show
|
||||
|
||||
instance Functor Dispatch where
|
||||
fmap f (Methods a b) = Methods (fmap f a) b
|
||||
fmap f (Subsite a b) = Subsite (f a) b
|
||||
|
||||
instance Lift t => Lift (Dispatch t) where
|
||||
lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
|
||||
lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]
|
||||
lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]
|
||||
|
||||
resourceMulti :: Resource typ -> Maybe typ
|
||||
resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
|
||||
resourceMulti _ = Nothing
|
||||
@ -74,7 +90,7 @@ data FlatResource a = FlatResource
|
||||
, frPieces :: [Piece a]
|
||||
, frDispatch :: Dispatch a
|
||||
, frCheck :: Bool
|
||||
} deriving (Show)
|
||||
}
|
||||
|
||||
flatten :: [ResourceTree a] -> [FlatResource a]
|
||||
flatten =
|
||||
@ -5,20 +5,26 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Main where
|
||||
|
||||
import Gauge.Main
|
||||
import Criterion.Main
|
||||
import Text.Hamlet
|
||||
import Numeric (showInt)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
|
||||
import Data.Monoid (mconcat)
|
||||
import Text.Blaze.Html5 (table, tr, td)
|
||||
import Text.Blaze.Html (toHtml)
|
||||
import Data.Int
|
||||
import Yesod.Core.Widget
|
||||
import Control.Monad.Trans.Writer
|
||||
import Control.Monad.Trans.RWS
|
||||
import Data.Functor.Identity
|
||||
import Yesod.Core.Types
|
||||
import Data.Monoid
|
||||
import Data.IORef
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
[ bench "bigTable html" $ nf bigTableHtml bigTableData
|
||||
, bench "bigTable hamlet" $ nf bigTableHamlet bigTableData
|
||||
--, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
|
||||
, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
|
||||
, bench "bigTable blaze" $ nf bigTableBlaze bigTableData
|
||||
]
|
||||
where
|
||||
@ -29,7 +35,6 @@ main = defaultMain
|
||||
bigTableData = replicate rows [1..10]
|
||||
{-# NOINLINE bigTableData #-}
|
||||
|
||||
bigTableHtml :: Show a => [[a]] -> Int64
|
||||
bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
|
||||
<table>
|
||||
$forall row <- rows
|
||||
@ -38,7 +43,6 @@ bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
|
||||
<td>#{show cell}
|
||||
|]
|
||||
|
||||
bigTableHamlet :: Show a => [[a]] -> Int64
|
||||
bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
|
||||
<table>
|
||||
$forall row <- rows
|
||||
@ -47,8 +51,6 @@ bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
|
||||
<td>#{show cell}
|
||||
|]
|
||||
|
||||
{-
|
||||
bigTableWidget :: Show a => [[a]] -> IO Int64
|
||||
bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|
|
||||
<table>
|
||||
$forall row <- rows
|
||||
@ -61,9 +63,7 @@ bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whaml
|
||||
run (WidgetT w) = do
|
||||
(_, GWData { gwdBody = Body x }) <- w undefined
|
||||
return x
|
||||
-}
|
||||
|
||||
bigTableBlaze :: Show a => [[a]] -> Int64
|
||||
bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t
|
||||
bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ mconcat $ map row t
|
||||
where
|
||||
row r = tr $ mconcat $ map (td . toHtml . show) r
|
||||
|
||||
@ -1,52 +0,0 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Core.Class.Dispatch where
|
||||
|
||||
import qualified Network.Wai as W
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Content (ToTypedContent (..))
|
||||
import Yesod.Core.Handler (sendWaiApplication)
|
||||
import Yesod.Core.Class.Yesod
|
||||
|
||||
-- | This class is automatically instantiated when you use the template haskell
|
||||
-- mkYesod function. You should never need to deal with it directly.
|
||||
class Yesod site => YesodDispatch site where
|
||||
yesodDispatch :: YesodRunnerEnv site -> W.Application
|
||||
|
||||
class YesodSubDispatch sub master where
|
||||
yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application
|
||||
|
||||
instance YesodSubDispatch WaiSubsite master where
|
||||
yesodSubDispatch YesodSubRunnerEnv {..} = app
|
||||
where
|
||||
WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
|
||||
|
||||
instance YesodSubDispatch WaiSubsiteWithAuth master where
|
||||
yesodSubDispatch YesodSubRunnerEnv {..} req =
|
||||
ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
|
||||
where
|
||||
route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []
|
||||
WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
|
||||
handlert = sendWaiApplication set
|
||||
|
||||
subHelper
|
||||
:: ToTypedContent content
|
||||
=> SubHandlerFor child master content
|
||||
-> YesodSubRunnerEnv child master
|
||||
-> Maybe (Route child)
|
||||
-> W.Application
|
||||
subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =
|
||||
ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)
|
||||
where
|
||||
handler = fmap toTypedContent $ HandlerFor $ \hd ->
|
||||
let rhe = handlerEnv hd
|
||||
rhe' = rhe
|
||||
{ rheRoute = mroute
|
||||
, rheChild = ysreGetSub $ yreSite ysreParentEnv
|
||||
, rheRouteToMaster = ysreToParentRoute
|
||||
}
|
||||
in f hd { handlerEnv = rhe' }
|
||||
@ -1,126 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Yesod.Core.Class.Handler
|
||||
( MonadHandler (..)
|
||||
, MonadWidget (..)
|
||||
, liftHandlerT
|
||||
, liftWidgetT
|
||||
) where
|
||||
|
||||
import Yesod.Core.Types
|
||||
import Control.Monad.Logger (MonadLogger)
|
||||
import Control.Monad.Trans.Resource (MonadResource)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Conduit.Internal (Pipe, ConduitM)
|
||||
|
||||
import Control.Monad.Trans.Identity ( IdentityT)
|
||||
#if !MIN_VERSION_transformers(0,6,0)
|
||||
import Control.Monad.Trans.List ( ListT )
|
||||
#endif
|
||||
import Control.Monad.Trans.Maybe ( MaybeT )
|
||||
import Control.Monad.Trans.Except ( ExceptT )
|
||||
import Control.Monad.Trans.Reader ( ReaderT )
|
||||
import Control.Monad.Trans.State ( StateT )
|
||||
import Control.Monad.Trans.Writer ( WriterT )
|
||||
import Control.Monad.Trans.RWS ( RWST )
|
||||
import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )
|
||||
import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )
|
||||
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
|
||||
|
||||
-- FIXME should we just use MonadReader instances instead?
|
||||
class (MonadResource m, MonadLogger m) => MonadHandler m where
|
||||
type HandlerSite m
|
||||
type SubHandlerSite m
|
||||
liftHandler :: HandlerFor (HandlerSite m) a -> m a
|
||||
liftSubHandler :: SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a
|
||||
|
||||
liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a
|
||||
liftHandlerT = liftHandler
|
||||
{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-}
|
||||
|
||||
instance MonadHandler (HandlerFor site) where
|
||||
type HandlerSite (HandlerFor site) = site
|
||||
type SubHandlerSite (HandlerFor site) = site
|
||||
liftHandler = id
|
||||
{-# INLINE liftHandler #-}
|
||||
liftSubHandler (SubHandlerFor f) = HandlerFor f
|
||||
{-# INLINE liftSubHandler #-}
|
||||
|
||||
instance MonadHandler (SubHandlerFor sub master) where
|
||||
type HandlerSite (SubHandlerFor sub master) = master
|
||||
type SubHandlerSite (SubHandlerFor sub master) = sub
|
||||
liftHandler (HandlerFor f) = SubHandlerFor $ \hd -> f hd
|
||||
{ handlerEnv =
|
||||
let rhe = handlerEnv hd
|
||||
in rhe
|
||||
{ rheRoute = fmap (rheRouteToMaster rhe) (rheRoute rhe)
|
||||
, rheRouteToMaster = id
|
||||
, rheChild = rheSite rhe
|
||||
}
|
||||
}
|
||||
{-# INLINE liftHandler #-}
|
||||
liftSubHandler = id
|
||||
{-# INLINE liftSubHandler #-}
|
||||
|
||||
instance MonadHandler (WidgetFor site) where
|
||||
type HandlerSite (WidgetFor site) = site
|
||||
type SubHandlerSite (WidgetFor site) = site
|
||||
liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler
|
||||
{-# INLINE liftHandler #-}
|
||||
liftSubHandler (SubHandlerFor f) = WidgetFor $ f . wdHandler
|
||||
{-# INLINE liftSubHandler #-}
|
||||
|
||||
#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
|
||||
#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
|
||||
GO(IdentityT)
|
||||
#if !MIN_VERSION_transformers(0,6,0)
|
||||
GO(ListT)
|
||||
#endif
|
||||
GO(MaybeT)
|
||||
GO(ExceptT e)
|
||||
GO(ReaderT r)
|
||||
GO(StateT s)
|
||||
GOX(Monoid w, WriterT w)
|
||||
GOX(Monoid w, RWST r w s)
|
||||
GOX(Monoid w, Strict.RWST r w s)
|
||||
GO(Strict.StateT s)
|
||||
GOX(Monoid w, Strict.WriterT w)
|
||||
GO(Pipe l i o u)
|
||||
GO(ConduitM i o)
|
||||
#undef GO
|
||||
#undef GOX
|
||||
|
||||
class MonadHandler m => MonadWidget m where
|
||||
liftWidget :: WidgetFor (HandlerSite m) a -> m a
|
||||
instance MonadWidget (WidgetFor site) where
|
||||
liftWidget = id
|
||||
{-# INLINE liftWidget #-}
|
||||
|
||||
liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a
|
||||
liftWidgetT = liftWidget
|
||||
{-# DEPRECATED liftWidgetT "Use liftWidget instead" #-}
|
||||
|
||||
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget
|
||||
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget
|
||||
GO(IdentityT)
|
||||
#if !MIN_VERSION_transformers(0,6,0)
|
||||
GO(ListT)
|
||||
#endif
|
||||
GO(MaybeT)
|
||||
GO(ExceptT e)
|
||||
GO(ReaderT r)
|
||||
GO(StateT s)
|
||||
GOX(Monoid w, WriterT w)
|
||||
GOX(Monoid w, RWST r w s)
|
||||
GOX(Monoid w, Strict.RWST r w s)
|
||||
GO(Strict.StateT s)
|
||||
GOX(Monoid w, Strict.WriterT w)
|
||||
GO(Pipe l i o u)
|
||||
GO(ConduitM i o)
|
||||
#undef GO
|
||||
#undef GOX
|
||||
@ -1,354 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Yesod.Core.Internal.TH
|
||||
( mkYesod
|
||||
, mkYesodOpts
|
||||
|
||||
, mkYesodWith
|
||||
|
||||
, mkYesodData
|
||||
, mkYesodDataOpts
|
||||
|
||||
, mkYesodSubData
|
||||
, mkYesodSubDataOpts
|
||||
|
||||
, mkYesodWithParser
|
||||
, mkYesodWithParserOpts
|
||||
|
||||
, mkYesodDispatch
|
||||
, mkYesodDispatchOpts
|
||||
|
||||
, masterTypeSyns
|
||||
|
||||
, mkYesodGeneral
|
||||
, mkYesodGeneralOpts
|
||||
|
||||
, mkMDS
|
||||
, mkDispatchInstance
|
||||
|
||||
, mkYesodSubDispatch
|
||||
|
||||
, subTopDispatch
|
||||
, instanceD
|
||||
|
||||
, RouteOpts
|
||||
, defaultOpts
|
||||
, setEqDerived
|
||||
, setShowDerived
|
||||
, setReadDerived
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude hiding (exp)
|
||||
import Yesod.Core.Handler
|
||||
|
||||
import Language.Haskell.TH hiding (cxt, instanceD)
|
||||
import Language.Haskell.TH.Syntax
|
||||
|
||||
import qualified Network.Wai as W
|
||||
|
||||
import Data.ByteString.Lazy.Char8 ()
|
||||
import Data.List (foldl')
|
||||
import Control.Monad (replicateM, void)
|
||||
import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)
|
||||
import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
|
||||
|
||||
import Yesod.Routes.TH
|
||||
import Yesod.Routes.Parse
|
||||
import Yesod.Core.Content (ToTypedContent (..))
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Class.Dispatch
|
||||
import Yesod.Core.Internal.Run
|
||||
|
||||
-- | Generates URL datatype and site function for the given 'Resource's. This
|
||||
-- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter.
|
||||
-- Use 'parseRoutes' to create the 'Resource's.
|
||||
--
|
||||
-- Contexts and type variables in the name of the datatype are parsed.
|
||||
-- For example, a datatype @App a@ with typeclass constraint @MyClass a@ can be written as @\"(MyClass a) => App a\"@.
|
||||
mkYesod :: String -- ^ name of the argument datatype
|
||||
-> [ResourceTree String]
|
||||
-> Q [Dec]
|
||||
mkYesod = mkYesodOpts defaultOpts
|
||||
|
||||
-- | `mkYesod` but with custom options.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodOpts :: RouteOpts
|
||||
-> String
|
||||
-> [ResourceTree String]
|
||||
-> Q [Dec]
|
||||
mkYesodOpts opts name = fmap (uncurry (++)) . mkYesodWithParserOpts opts name False return
|
||||
|
||||
|
||||
{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}
|
||||
-- | Similar to 'mkYesod', except contexts and type variables are not parsed.
|
||||
-- Instead, they are explicitly provided.
|
||||
-- You can write @(MyClass a) => App a@ with @mkYesodWith [[\"MyClass\",\"a\"]] \"App\" [\"a\"] ...@.
|
||||
mkYesodWith :: [[String]] -- ^ list of contexts
|
||||
-> String -- ^ name of the argument datatype
|
||||
-> [String] -- ^ list of type variables
|
||||
-> [ResourceTree String]
|
||||
-> Q [Dec]
|
||||
mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return
|
||||
|
||||
|
||||
-- | Sometimes, you will want to declare your routes in one file and define
|
||||
-- your handlers elsewhere. For example, this is the only way to break up a
|
||||
-- monolithic file into smaller parts. Use this function, paired with
|
||||
-- 'mkYesodDispatch', to do just that.
|
||||
mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodData = mkYesodDataOpts defaultOpts
|
||||
|
||||
-- | `mkYesodData` but with custom options.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name False return resS
|
||||
|
||||
|
||||
mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodSubData = mkYesodSubDataOpts defaultOpts
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodSubDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name True return resS
|
||||
|
||||
|
||||
-- | Parses contexts and type arguments out of name before generating TH.
|
||||
mkYesodWithParser :: String -- ^ foundation type
|
||||
-> Bool -- ^ is this a subsite
|
||||
-> (Exp -> Q Exp) -- ^ unwrap handler
|
||||
-> [ResourceTree String]
|
||||
-> Q([Dec],[Dec])
|
||||
mkYesodWithParser = mkYesodWithParserOpts defaultOpts
|
||||
|
||||
-- | Parses contexts and type arguments out of name before generating TH.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodWithParserOpts :: RouteOpts -- ^ Additional route options
|
||||
-> String -- ^ foundation type
|
||||
-> Bool -- ^ is this a subsite
|
||||
-> (Exp -> Q Exp) -- ^ unwrap handler
|
||||
-> [ResourceTree String]
|
||||
-> Q([Dec],[Dec])
|
||||
mkYesodWithParserOpts opts name isSub f resS = do
|
||||
let (name', rest, cxt) = case parse parseName "" name of
|
||||
Left err -> error $ show err
|
||||
Right a -> a
|
||||
mkYesodGeneralOpts opts cxt name' rest isSub f resS
|
||||
|
||||
where
|
||||
parseName = do
|
||||
cxt <- option [] parseContext
|
||||
name' <- parseWord
|
||||
args <- many parseWord
|
||||
spaces
|
||||
eof
|
||||
return ( name', args, cxt)
|
||||
|
||||
parseWord = do
|
||||
spaces
|
||||
many1 alphaNum
|
||||
|
||||
parseContext = try $ do
|
||||
cxts <- parseParen parseContexts
|
||||
spaces
|
||||
_ <- string "=>"
|
||||
return cxts
|
||||
|
||||
parseParen p = do
|
||||
spaces
|
||||
_ <- char '('
|
||||
r <- p
|
||||
spaces
|
||||
_ <- char ')'
|
||||
return r
|
||||
|
||||
parseContexts =
|
||||
sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
|
||||
|
||||
|
||||
-- | See 'mkYesodData'.
|
||||
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodDispatch = mkYesodDispatchOpts defaultOpts
|
||||
|
||||
-- | See 'mkYesodDataOpts'
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodDispatchOpts opts name = fmap snd . mkYesodWithParserOpts opts name False return
|
||||
|
||||
|
||||
-- | Get the Handler and Widget type synonyms for the given site.
|
||||
masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself?
|
||||
masterTypeSyns vs site =
|
||||
[ TySynD (mkName "Handler") (fmap plainTV vs)
|
||||
$ ConT ''HandlerFor `AppT` site
|
||||
, TySynD (mkName "Widget") (fmap plainTV vs)
|
||||
$ ConT ''WidgetFor `AppT` site `AppT` ConT ''()
|
||||
]
|
||||
|
||||
|
||||
mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
|
||||
-> String -- ^ foundation type
|
||||
-> [String] -- ^ arguments for the type
|
||||
-> Bool -- ^ is this a subsite
|
||||
-> (Exp -> Q Exp) -- ^ unwrap handler
|
||||
-> [ResourceTree String]
|
||||
-> Q([Dec],[Dec])
|
||||
mkYesodGeneral = mkYesodGeneralOpts defaultOpts
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodGeneralOpts :: RouteOpts -- ^ Options to adjust route creation
|
||||
-> [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
|
||||
-> String -- ^ foundation type
|
||||
-> [String] -- ^ arguments for the type
|
||||
-> Bool -- ^ is this a subsite
|
||||
-> (Exp -> Q Exp) -- ^ unwrap handler
|
||||
-> [ResourceTree String]
|
||||
-> Q([Dec],[Dec])
|
||||
mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
|
||||
let appCxt = fmap (\(c:rest) ->
|
||||
foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
|
||||
) appCxt'
|
||||
mname <- lookupTypeName namestr
|
||||
arity <- case mname of
|
||||
Just name -> do
|
||||
info <- reify name
|
||||
return $
|
||||
case info of
|
||||
TyConI dec ->
|
||||
case dec of
|
||||
DataD _ _ vs _ _ _ -> length vs
|
||||
NewtypeD _ _ vs _ _ _ -> length vs
|
||||
TySynD _ vs _ -> length vs
|
||||
_ -> 0
|
||||
_ -> 0
|
||||
_ -> return 0
|
||||
let name = mkName namestr
|
||||
-- Generate as many variable names as the arity indicates
|
||||
vns <- replicateM (arity - length mtys) $ newName "t"
|
||||
-- types that you apply to get a concrete site name
|
||||
let argtypes = fmap nameToType mtys ++ fmap VarT vns
|
||||
-- typevars that should appear in synonym head
|
||||
let argvars = (fmap mkName . filter isTvar) mtys ++ vns
|
||||
-- Base type (site type with variables)
|
||||
let site = foldl' AppT (ConT name) argtypes
|
||||
res = map (fmap (parseType . dropBracket)) resS
|
||||
renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res
|
||||
routeAttrsDec <- mkRouteAttrsInstance appCxt site res
|
||||
dispatchDec <- mkDispatchInstance site appCxt f res
|
||||
parseRoute <- mkParseRouteInstance appCxt site res
|
||||
let rname = mkName $ "resources" ++ namestr
|
||||
eres <- lift resS
|
||||
let resourcesDec =
|
||||
[ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
|
||||
, FunD rname [Clause [] (NormalB eres) []]
|
||||
]
|
||||
let dataDec = concat
|
||||
[ [parseRoute]
|
||||
, renderRouteDec
|
||||
, [routeAttrsDec]
|
||||
, resourcesDec
|
||||
, if isSub then [] else masterTypeSyns argvars site
|
||||
]
|
||||
return (dataDec, dispatchDec)
|
||||
|
||||
|
||||
mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
|
||||
mkMDS f rh sd = MkDispatchSettings
|
||||
{ mdsRunHandler = rh
|
||||
, mdsSubDispatcher = sd
|
||||
, mdsGetPathInfo = [|W.pathInfo|]
|
||||
, mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
|
||||
, mdsMethod = [|W.requestMethod|]
|
||||
, mds404 = [|void notFound|]
|
||||
, mds405 = [|void badMethod|]
|
||||
, mdsGetHandler = defaultGetHandler
|
||||
, mdsUnwrapper = f
|
||||
}
|
||||
|
||||
-- | If the generation of @'YesodDispatch'@ instance require finer
|
||||
-- control of the types, contexts etc. using this combinator. You will
|
||||
-- hardly need this generality. However, in certain situations, like
|
||||
-- when writing library/plugin for yesod, this combinator becomes
|
||||
-- handy.
|
||||
mkDispatchInstance :: Type -- ^ The master site type
|
||||
-> Cxt -- ^ Context of the instance
|
||||
-> (Exp -> Q Exp) -- ^ Unwrap handler
|
||||
-> [ResourceTree c] -- ^ The resource
|
||||
-> DecsQ
|
||||
mkDispatchInstance master cxt f res = do
|
||||
clause' <-
|
||||
mkDispatchClause
|
||||
(mkMDS
|
||||
f
|
||||
[|yesodRunner|]
|
||||
[|\parentRunner getSub toParent env -> yesodSubDispatch
|
||||
YesodSubRunnerEnv
|
||||
{ ysreParentRunner = parentRunner
|
||||
, ysreGetSub = getSub
|
||||
, ysreToParentRoute = toParent
|
||||
, ysreParentEnv = env
|
||||
}
|
||||
|])
|
||||
res
|
||||
let thisDispatch = FunD 'yesodDispatch [clause']
|
||||
return [instanceD cxt yDispatch [thisDispatch]]
|
||||
where
|
||||
yDispatch = ConT ''YesodDispatch `AppT` master
|
||||
|
||||
|
||||
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
|
||||
mkYesodSubDispatch res = do
|
||||
clause' <-
|
||||
mkDispatchClause
|
||||
(mkMDS
|
||||
return
|
||||
[|subHelper|]
|
||||
[|subTopDispatch|])
|
||||
res
|
||||
inner <- newName "inner"
|
||||
let innerFun = FunD inner [clause']
|
||||
helper <- newName "helper"
|
||||
let fun = FunD helper
|
||||
[ Clause
|
||||
[]
|
||||
(NormalB $ VarE inner)
|
||||
[innerFun]
|
||||
]
|
||||
return $ LetE [fun] (VarE helper)
|
||||
|
||||
|
||||
subTopDispatch ::
|
||||
(YesodSubDispatch sub master) =>
|
||||
(forall content. ToTypedContent content =>
|
||||
SubHandlerFor child master content ->
|
||||
YesodSubRunnerEnv child master ->
|
||||
Maybe (Route child) ->
|
||||
W.Application
|
||||
) ->
|
||||
(mid -> sub) ->
|
||||
(Route sub -> Route mid) ->
|
||||
YesodSubRunnerEnv mid master ->
|
||||
W.Application
|
||||
subTopDispatch _ getSub toParent env = yesodSubDispatch
|
||||
(YesodSubRunnerEnv
|
||||
{ ysreParentRunner = ysreParentRunner env
|
||||
, ysreGetSub = getSub . ysreGetSub env
|
||||
, ysreToParentRoute = ysreToParentRoute env . toParent
|
||||
, ysreParentEnv = ysreParentEnv env
|
||||
})
|
||||
|
||||
instanceD :: Cxt -> Type -> [Dec] -> Dec
|
||||
instanceD = InstanceD Nothing
|
||||
@ -1,264 +0,0 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
|
||||
module Yesod.Routes.TH.RenderRoute
|
||||
( -- ** RenderRoute
|
||||
mkRenderRouteInstance
|
||||
, mkRenderRouteInstanceOpts
|
||||
, mkRouteCons
|
||||
, mkRouteConsOpts
|
||||
, mkRenderRouteClauses
|
||||
|
||||
, RouteOpts
|
||||
, defaultOpts
|
||||
, setEqDerived
|
||||
, setShowDerived
|
||||
, setReadDerived
|
||||
) where
|
||||
|
||||
import Yesod.Routes.TH.Types
|
||||
import Language.Haskell.TH (conT)
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Bits (xor)
|
||||
import Data.Maybe (maybeToList)
|
||||
import Control.Monad (replicateM)
|
||||
import Data.Text (pack)
|
||||
import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
|
||||
import Yesod.Routes.Class
|
||||
|
||||
-- | General opts data type for generating yesod.
|
||||
--
|
||||
-- Contains options for what instances are derived for the route. Use the setting
|
||||
-- functions on `defaultOpts` to set specific fields.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
data RouteOpts = MkRouteOpts
|
||||
{ roDerivedEq :: Bool
|
||||
, roDerivedShow :: Bool
|
||||
, roDerivedRead :: Bool
|
||||
}
|
||||
|
||||
-- | Default options for generating routes.
|
||||
--
|
||||
-- Defaults to all instances derived.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
defaultOpts :: RouteOpts
|
||||
defaultOpts = MkRouteOpts True True True
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
setEqDerived :: Bool -> RouteOpts -> RouteOpts
|
||||
setEqDerived b rdo = rdo { roDerivedEq = b }
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
setShowDerived :: Bool -> RouteOpts -> RouteOpts
|
||||
setShowDerived b rdo = rdo { roDerivedShow = b }
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
setReadDerived :: Bool -> RouteOpts -> RouteOpts
|
||||
setReadDerived b rdo = rdo { roDerivedRead = b }
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
instanceNamesFromOpts :: RouteOpts -> [Name]
|
||||
instanceNamesFromOpts (MkRouteOpts eq shw rd) = prependIf eq ''Eq $ prependIf shw ''Show $ prependIf rd ''Read []
|
||||
where prependIf b = if b then (:) else const id
|
||||
|
||||
-- | Generate the constructors of a route data type.
|
||||
mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])
|
||||
mkRouteCons = mkRouteConsOpts defaultOpts
|
||||
|
||||
-- | Generate the constructors of a route data type, with custom opts.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkRouteConsOpts :: RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])
|
||||
mkRouteConsOpts opts rttypes =
|
||||
mconcat <$> mapM mkRouteCon rttypes
|
||||
where
|
||||
mkRouteCon (ResourceLeaf res) =
|
||||
return ([con], [])
|
||||
where
|
||||
con = NormalC (mkName $ resourceName res)
|
||||
$ map (notStrict,)
|
||||
$ concat [singles, multi, sub]
|
||||
singles = concatMap toSingle $ resourcePieces res
|
||||
toSingle Static{} = []
|
||||
toSingle (Dynamic typ) = [typ]
|
||||
|
||||
multi = maybeToList $ resourceMulti res
|
||||
|
||||
sub =
|
||||
case resourceDispatch res of
|
||||
Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
|
||||
_ -> []
|
||||
|
||||
mkRouteCon (ResourceParent name _check pieces children) = do
|
||||
(cons, decs) <- mkRouteConsOpts opts children
|
||||
let conts = mapM conT $ instanceNamesFromOpts opts
|
||||
#if MIN_VERSION_template_haskell(2,12,0)
|
||||
dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) conts
|
||||
#else
|
||||
dec <- DataD [] (mkName name) [] Nothing cons <$> conts
|
||||
#endif
|
||||
return ([con], dec : decs)
|
||||
where
|
||||
con = NormalC (mkName name)
|
||||
$ map (notStrict,)
|
||||
$ singles ++ [ConT $ mkName name]
|
||||
|
||||
singles = concatMap toSingle pieces
|
||||
toSingle Static{} = []
|
||||
toSingle (Dynamic typ) = [typ]
|
||||
|
||||
-- | Clauses for the 'renderRoute' method.
|
||||
mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]
|
||||
mkRenderRouteClauses =
|
||||
mapM go
|
||||
where
|
||||
isDynamic Dynamic{} = True
|
||||
isDynamic _ = False
|
||||
|
||||
go (ResourceParent name _check pieces children) = do
|
||||
let cnt = length $ filter isDynamic pieces
|
||||
dyns <- replicateM cnt $ newName "dyn"
|
||||
child <- newName "child"
|
||||
let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child]
|
||||
|
||||
pack' <- [|pack|]
|
||||
tsp <- [|toPathPiece|]
|
||||
let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns
|
||||
|
||||
childRender <- newName "childRender"
|
||||
let rr = VarE childRender
|
||||
childClauses <- mkRenderRouteClauses children
|
||||
|
||||
a <- newName "a"
|
||||
b <- newName "b"
|
||||
|
||||
colon <- [|(:)|]
|
||||
let cons y ys = InfixE (Just y) colon (Just ys)
|
||||
let pieces' = foldr cons (VarE a) piecesSingle
|
||||
|
||||
let body = LamE [TupP [VarP a, VarP b]] (TupE
|
||||
#if MIN_VERSION_template_haskell(2,16,0)
|
||||
$ map Just
|
||||
#endif
|
||||
[pieces', VarE b]
|
||||
) `AppE` (rr `AppE` VarE child)
|
||||
|
||||
return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
|
||||
|
||||
go (ResourceLeaf res) = do
|
||||
let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
|
||||
dyns <- replicateM cnt $ newName "dyn"
|
||||
sub <-
|
||||
case resourceDispatch res of
|
||||
Subsite{} -> return <$> newName "sub"
|
||||
_ -> return []
|
||||
let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub
|
||||
|
||||
pack' <- [|pack|]
|
||||
tsp <- [|toPathPiece|]
|
||||
let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns
|
||||
|
||||
piecesMulti <-
|
||||
case resourceMulti res of
|
||||
Nothing -> return $ ListE []
|
||||
Just{} -> do
|
||||
tmp <- [|toPathMultiPiece|]
|
||||
return $ tmp `AppE` VarE (last dyns)
|
||||
|
||||
body <-
|
||||
case sub of
|
||||
[x] -> do
|
||||
rr <- [|renderRoute|]
|
||||
a <- newName "a"
|
||||
b <- newName "b"
|
||||
|
||||
colon <- [|(:)|]
|
||||
let cons y ys = InfixE (Just y) colon (Just ys)
|
||||
let pieces = foldr cons (VarE a) piecesSingle
|
||||
|
||||
return $ LamE [TupP [VarP a, VarP b]] (TupE
|
||||
#if MIN_VERSION_template_haskell(2,16,0)
|
||||
$ map Just
|
||||
#endif
|
||||
[pieces, VarE b]
|
||||
) `AppE` (rr `AppE` VarE x)
|
||||
_ -> do
|
||||
colon <- [|(:)|]
|
||||
let cons a b = InfixE (Just a) colon (Just b)
|
||||
return $ TupE
|
||||
#if MIN_VERSION_template_haskell(2,16,0)
|
||||
$ map Just
|
||||
#endif
|
||||
[foldr cons piecesMulti piecesSingle, ListE []]
|
||||
|
||||
return $ Clause [pat] (NormalB body) []
|
||||
|
||||
mkPieces _ _ [] _ = []
|
||||
mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns
|
||||
mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns
|
||||
mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120"
|
||||
|
||||
-- | Generate the 'RenderRoute' instance.
|
||||
--
|
||||
-- This includes both the 'Route' associated type and the
|
||||
-- 'renderRoute' method. This function uses both 'mkRouteCons' and
|
||||
-- 'mkRenderRouteClasses'.
|
||||
mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
|
||||
mkRenderRouteInstance = mkRenderRouteInstanceOpts defaultOpts
|
||||
|
||||
-- | Generate the 'RenderRoute' instance.
|
||||
--
|
||||
-- This includes both the 'Route' associated type and the
|
||||
-- 'renderRoute' method. This function uses both 'mkRouteCons' and
|
||||
-- 'mkRenderRouteClasses'.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
|
||||
mkRenderRouteInstanceOpts opts cxt typ ress = do
|
||||
cls <- mkRenderRouteClauses ress
|
||||
(cons, decs) <- mkRouteConsOpts opts ress
|
||||
#if MIN_VERSION_template_haskell(2,15,0)
|
||||
did <- DataInstD [] Nothing (AppT (ConT ''Route) typ) Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
|
||||
let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
|
||||
#elif MIN_VERSION_template_haskell(2,12,0)
|
||||
did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
|
||||
let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
|
||||
#else
|
||||
did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)
|
||||
let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
|
||||
#endif
|
||||
return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)
|
||||
[ did
|
||||
, FunD (mkName "renderRoute") cls
|
||||
]
|
||||
: sds ++ decs
|
||||
where
|
||||
clazzes standalone = if standalone `xor` null cxt then
|
||||
clazzes'
|
||||
else
|
||||
[]
|
||||
clazzes' = instanceNamesFromOpts opts
|
||||
|
||||
notStrict :: Bang
|
||||
notStrict = Bang NoSourceUnpackedness NoSourceStrictness
|
||||
|
||||
instanceD :: Cxt -> Type -> [Dec] -> Dec
|
||||
instanceD = InstanceD Nothing
|
||||
|
||||
conPCompat :: Name -> [Pat] -> Pat
|
||||
conPCompat n pats = ConP n
|
||||
#if MIN_VERSION_template_haskell(2,18,0)
|
||||
[]
|
||||
#endif
|
||||
pats
|
||||
5
yesod-core/test.hs
Normal file
5
yesod-core/test.hs
Normal file
@ -0,0 +1,5 @@
|
||||
import Test.Hspec
|
||||
import qualified YesodCoreTest
|
||||
|
||||
main :: IO ()
|
||||
main = hspec YesodCoreTest.specs
|
||||
@ -17,9 +17,6 @@ module Hierarchy
|
||||
, toText
|
||||
, Env (..)
|
||||
, subDispatch
|
||||
-- to avoid warnings
|
||||
, deleteDelete2
|
||||
, deleteDelete3
|
||||
) where
|
||||
|
||||
import Test.Hspec
|
||||
@ -113,9 +110,9 @@ do
|
||||
-- /#Int TrailingIntR GET
|
||||
|]
|
||||
|
||||
rrinst <- mkRenderRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
|
||||
rainst <- mkRouteAttrsInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
|
||||
prinst <- mkParseRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
|
||||
rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
|
||||
rainst <- mkRouteAttrsInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
|
||||
prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
|
||||
dispatch <- mkDispatchClause MkDispatchSettings
|
||||
{ mdsRunHandler = [|runHandler|]
|
||||
, mdsSubDispatcher = [|subDispatch|]
|
||||
|
||||
@ -17,7 +17,7 @@ import Test.HUnit ((@?=))
|
||||
import Data.Text (Text, pack, unpack, singleton)
|
||||
import Yesod.Routes.Class hiding (Route)
|
||||
import qualified Yesod.Routes.Class as YRC
|
||||
import Yesod.Routes.Parse (parseRoutesFile, parseRoutesNoCheck, parseTypeTree, TypeTree (..))
|
||||
import Yesod.Routes.Parse (parseRoutesNoCheck, parseTypeTree, TypeTree (..))
|
||||
import Yesod.Routes.Overlap (findOverlapNames)
|
||||
import Yesod.Routes.TH hiding (Dispatch)
|
||||
import Language.Haskell.TH.Syntax
|
||||
@ -30,7 +30,11 @@ data MyApp = MyApp
|
||||
data MySub = MySub
|
||||
instance RenderRoute MySub where
|
||||
data
|
||||
#if MIN_VERSION_base(4,5,0)
|
||||
Route
|
||||
#else
|
||||
YRC.Route
|
||||
#endif
|
||||
MySub = MySubRoute ([Text], [(Text, Text)])
|
||||
deriving (Show, Eq, Read)
|
||||
renderRoute (MySubRoute x) = x
|
||||
@ -43,7 +47,11 @@ getMySub MyApp = MySub
|
||||
data MySubParam = MySubParam Int
|
||||
instance RenderRoute MySubParam where
|
||||
data
|
||||
#if MIN_VERSION_base(4,5,0)
|
||||
Route
|
||||
#else
|
||||
YRC.Route
|
||||
#endif
|
||||
MySubParam = ParamRoute Char
|
||||
deriving (Show, Eq, Read)
|
||||
renderRoute (ParamRoute x) = ([singleton x], [])
|
||||
@ -72,9 +80,9 @@ do
|
||||
[ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True
|
||||
]
|
||||
ress = resParent : resLeaves
|
||||
rrinst <- mkRenderRouteInstance [] (ConT ''MyApp) ress
|
||||
rainst <- mkRouteAttrsInstance [] (ConT ''MyApp) ress
|
||||
prinst <- mkParseRouteInstance [] (ConT ''MyApp) ress
|
||||
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
|
||||
rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress
|
||||
prinst <- mkParseRouteInstance (ConT ''MyApp) ress
|
||||
dispatch <- mkDispatchClause MkDispatchSettings
|
||||
{ mdsRunHandler = [|runHandler|]
|
||||
, mdsSubDispatcher = [|subDispatch dispatcher|]
|
||||
@ -110,7 +118,7 @@ instance Dispatcher MySub master where
|
||||
route = MySubRoute (pieces, [])
|
||||
|
||||
instance Dispatcher MySubParam master where
|
||||
dispatcher env (pieces, _method) =
|
||||
dispatcher env (pieces, method) =
|
||||
case map unpack pieces of
|
||||
[[c]] ->
|
||||
let route = ParamRoute c
|
||||
@ -219,78 +227,63 @@ main = hspec $ do
|
||||
it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"]
|
||||
@?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q')
|
||||
|
||||
describe "route parsing" $ do
|
||||
describe "parsing" $ do
|
||||
it "subsites work" $ do
|
||||
parseRoute ([pack "subsite", pack "foo"], [(pack "bar", pack "baz")]) @?=
|
||||
Just (SubsiteR $ MySubRoute ([pack "foo"], [(pack "bar", pack "baz")]))
|
||||
|
||||
describe "routing table parsing" $ do
|
||||
it "recognizes trailing backslashes as line continuation directives" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations.yesodroutes")
|
||||
length routes @?= 3
|
||||
|
||||
describe "overlap checking" $ do
|
||||
it "catches overlapping statics" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = [parseRoutesNoCheck|
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/foo Foo1
|
||||
/foo Foo2
|
||||
|]
|
||||
findOverlapNames routes @?= [("Foo1", "Foo2")]
|
||||
it "catches overlapping dynamics" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = [parseRoutesNoCheck|
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/#Int Foo1
|
||||
/#String Foo2
|
||||
|]
|
||||
findOverlapNames routes @?= [("Foo1", "Foo2")]
|
||||
it "catches overlapping statics and dynamics" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = [parseRoutesNoCheck|
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/foo Foo1
|
||||
/#String Foo2
|
||||
|]
|
||||
findOverlapNames routes @?= [("Foo1", "Foo2")]
|
||||
it "catches overlapping multi" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = [parseRoutesNoCheck|
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/foo Foo1
|
||||
/##*Strings Foo2
|
||||
|]
|
||||
findOverlapNames routes @?= [("Foo1", "Foo2")]
|
||||
it "catches overlapping subsite" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = [parseRoutesNoCheck|
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/foo Foo1
|
||||
/foo Foo2 Subsite getSubsite
|
||||
|]
|
||||
findOverlapNames routes @?= [("Foo1", "Foo2")]
|
||||
it "no false positives" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = [parseRoutesNoCheck|
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/foo Foo1
|
||||
/bar/#String Foo2
|
||||
|]
|
||||
findOverlapNames routes @?= []
|
||||
it "obeys ignore rules" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = [parseRoutesNoCheck|
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/foo Foo1
|
||||
/#!String Foo2
|
||||
/!foo Foo3
|
||||
|]
|
||||
findOverlapNames routes @?= []
|
||||
it "obeys multipiece ignore rules #779" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = [parseRoutesNoCheck|
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/foo Foo1
|
||||
/+![String] Foo2
|
||||
|]
|
||||
findOverlapNames routes @?= []
|
||||
it "ignore rules for entire route #779" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = [parseRoutesNoCheck|
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/foo Foo1
|
||||
!/+[String] Foo2
|
||||
!/#String Foo3
|
||||
@ -298,8 +291,7 @@ main = hspec $ do
|
||||
|]
|
||||
findOverlapNames routes @?= []
|
||||
it "ignore rules for hierarchy" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = [parseRoutesNoCheck|
|
||||
let routes = [parseRoutesNoCheck|
|
||||
/+[String] Foo1
|
||||
!/foo Foo2:
|
||||
/foo Foo3
|
||||
@ -320,7 +312,7 @@ main = hspec $ do
|
||||
it "hierarchy" $ do
|
||||
routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child")
|
||||
hierarchy
|
||||
describe "parseRouteType" $ do
|
||||
describe "parseRouteTyoe" $ do
|
||||
let success s t = it s $ parseTypeTree s @?= Just t
|
||||
failure s = it s $ parseTypeTree s @?= Nothing
|
||||
success "Int" $ TTTerm "Int"
|
||||
@ -332,8 +324,6 @@ main = hspec $ do
|
||||
success "[Int]" $ TTList $ TTTerm "Int"
|
||||
success "Foo-Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar")
|
||||
success "Foo-Bar-Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz"
|
||||
success "Foo Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar")
|
||||
success "Foo Bar Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz"
|
||||
|
||||
getRootR :: Text
|
||||
getRootR = pack "this is the root"
|
||||
|
||||
@ -5,27 +5,17 @@ import YesodCoreTest.CleanPath
|
||||
import YesodCoreTest.Exceptions
|
||||
import YesodCoreTest.Widget
|
||||
import YesodCoreTest.Media
|
||||
import YesodCoreTest.Meta
|
||||
import YesodCoreTest.Links
|
||||
import YesodCoreTest.Header
|
||||
import YesodCoreTest.NoOverloadedStrings
|
||||
import YesodCoreTest.SubSub
|
||||
import YesodCoreTest.InternalRequest
|
||||
import YesodCoreTest.ErrorHandling
|
||||
import YesodCoreTest.Cache
|
||||
import YesodCoreTest.ParameterizedSite
|
||||
import YesodCoreTest.Breadcrumb
|
||||
import qualified YesodCoreTest.WaiSubsite as WaiSubsite
|
||||
import qualified YesodCoreTest.Redirect as Redirect
|
||||
import qualified YesodCoreTest.JsLoader as JsLoader
|
||||
import qualified YesodCoreTest.RequestBodySize as RequestBodySize
|
||||
import qualified YesodCoreTest.Json as Json
|
||||
|
||||
-- Skip on Windows, see https://github.com/yesodweb/yesod/issues/1523#issuecomment-398278450
|
||||
#if !WINDOWS
|
||||
import qualified YesodCoreTest.RawResponse as RawResponse
|
||||
#endif
|
||||
|
||||
import qualified YesodCoreTest.Streaming as Streaming
|
||||
import qualified YesodCoreTest.Reps as Reps
|
||||
import qualified YesodCoreTest.Auth as Auth
|
||||
@ -37,26 +27,21 @@ import Test.Hspec
|
||||
|
||||
specs :: Spec
|
||||
specs = do
|
||||
headerTest
|
||||
cleanPathTest
|
||||
exceptionsTest
|
||||
widgetTest
|
||||
mediaTest
|
||||
linksTest
|
||||
noOverloadedTest
|
||||
subSubTest
|
||||
internalRequestTest
|
||||
errorHandlingTest
|
||||
cacheTest
|
||||
parameterizedSiteTest
|
||||
WaiSubsite.specs
|
||||
Redirect.specs
|
||||
JsLoader.specs
|
||||
RequestBodySize.specs
|
||||
Json.specs
|
||||
#if !WINDOWS
|
||||
RawResponse.specs
|
||||
#endif
|
||||
Streaming.specs
|
||||
Reps.specs
|
||||
Auth.specs
|
||||
@ -65,5 +50,3 @@ specs = do
|
||||
Ssl.sslOnlySpec
|
||||
Ssl.sameSiteSpec
|
||||
Csrf.csrfSpec
|
||||
breadcrumbTest
|
||||
metaTest
|
||||
|
||||
@ -1,9 +1,5 @@
|
||||
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}
|
||||
module YesodCoreTest.Auth
|
||||
( specs
|
||||
, Widget
|
||||
, resourcesApp
|
||||
) where
|
||||
module YesodCoreTest.Auth (specs, Widget) where
|
||||
|
||||
import Yesod.Core
|
||||
import Test.Hspec
|
||||
|
||||
@ -1,58 +0,0 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module YesodCoreTest.Breadcrumb
|
||||
( breadcrumbTest,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
import Data.Text (Text)
|
||||
import Data.Typeable (Typeable)
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import Test.Hspec
|
||||
import UnliftIO.IORef
|
||||
import Yesod.Core
|
||||
|
||||
data A = A
|
||||
|
||||
mkYesod
|
||||
"A"
|
||||
[parseRoutes|
|
||||
/ RootR GET
|
||||
/loop LoopR GET
|
||||
|]
|
||||
|
||||
instance Yesod A
|
||||
|
||||
instance YesodBreadcrumbs A where
|
||||
breadcrumb r = case r of
|
||||
RootR -> pure ("Root", Nothing)
|
||||
LoopR -> pure ("Loop", Just LoopR) -- Purposefully a loop
|
||||
|
||||
getRootR :: Handler Text
|
||||
getRootR = fst <$> breadcrumbs
|
||||
|
||||
getLoopR :: Handler Text
|
||||
getLoopR = fst <$> breadcrumbs
|
||||
|
||||
breadcrumbTest :: Spec
|
||||
breadcrumbTest =
|
||||
describe "Test.Breadcrumb" $ do
|
||||
it "can fetch the root which contains breadcrumbs" $
|
||||
runner $ do
|
||||
res <- request defaultRequest
|
||||
assertStatus 200 res
|
||||
it "gets a 500 for a route with a looping breadcrumb" $
|
||||
runner $ do
|
||||
res <- request defaultRequest {pathInfo = ["loop"]}
|
||||
assertStatus 500 res
|
||||
|
||||
runner :: Session () -> IO ()
|
||||
runner f = toWaiApp A >>= runSession f
|
||||
@ -1,12 +1,9 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
module YesodCoreTest.Cache
|
||||
( cacheTest
|
||||
, Widget
|
||||
, resourcesC
|
||||
) where
|
||||
module YesodCoreTest.Cache (cacheTest, Widget) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
@ -14,15 +11,17 @@ import Network.Wai
|
||||
import Network.Wai.Test
|
||||
|
||||
import Yesod.Core
|
||||
import UnliftIO.IORef
|
||||
import Data.IORef.Lifted
|
||||
import Data.Typeable (Typeable)
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
|
||||
data C = C
|
||||
|
||||
newtype V1 = V1 Int
|
||||
deriving Typeable
|
||||
|
||||
newtype V2 = V2 Int
|
||||
deriving Typeable
|
||||
|
||||
mkYesod "C" [parseRoutes|
|
||||
/ RootR GET
|
||||
@ -43,14 +42,7 @@ getRootR = do
|
||||
V2 v2a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
|
||||
V2 v2b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
|
||||
|
||||
cacheBySet "3" (V2 3)
|
||||
V2 v3a <- cacheByGet "3" >>= \x ->
|
||||
case x of
|
||||
Just y -> return y
|
||||
Nothing -> error "must be Just"
|
||||
V2 v3b <- cachedBy "3" $ (pure $ V2 4)
|
||||
|
||||
return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b]
|
||||
return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b]
|
||||
|
||||
getKeyR :: Handler RepPlain
|
||||
getKeyR = do
|
||||
@ -64,15 +56,7 @@ getKeyR = do
|
||||
V2 v3a <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
|
||||
V2 v3b <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
|
||||
|
||||
|
||||
cacheBySet "4" (V2 4)
|
||||
V2 v4a <- cacheByGet "4" >>= \x ->
|
||||
case x of
|
||||
Just y -> return y
|
||||
Nothing -> error "must be Just"
|
||||
V2 v4b <- cachedBy "4" $ (pure $ V2 5)
|
||||
|
||||
return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b, v4a, v4b]
|
||||
return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b]
|
||||
|
||||
getNestedR :: Handler RepPlain
|
||||
getNestedR = getNested cached
|
||||
@ -98,12 +82,12 @@ cacheTest =
|
||||
it "cached" $ runner $ do
|
||||
res <- request defaultRequest
|
||||
assertStatus 200 res
|
||||
assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res
|
||||
assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res
|
||||
|
||||
it "cachedBy" $ runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["key"] }
|
||||
assertStatus 200 res
|
||||
assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3, 4, 4 :: Int]) res
|
||||
assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res
|
||||
|
||||
it "nested cached" $ runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["nested"] }
|
||||
|
||||
@ -2,11 +2,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module YesodCoreTest.CleanPath
|
||||
( cleanPathTest
|
||||
, Widget
|
||||
, resourcesY
|
||||
) where
|
||||
module YesodCoreTest.CleanPath (cleanPathTest, Widget) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
@ -22,7 +18,7 @@ import qualified Data.Text.Encoding as TE
|
||||
import Control.Arrow ((***))
|
||||
import Network.HTTP.Types (encodePath)
|
||||
import Data.Monoid (mappend)
|
||||
import Data.Text.Encoding (encodeUtf8Builder)
|
||||
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
||||
|
||||
data Subsite = Subsite
|
||||
|
||||
@ -64,7 +60,7 @@ instance Yesod Y where
|
||||
corrected = filter (not . TS.null) s
|
||||
|
||||
joinPath Y ar pieces' qs' =
|
||||
encodeUtf8Builder ar `Data.Monoid.mappend` encodePath pieces qs
|
||||
fromText ar `mappend` encodePath pieces qs
|
||||
where
|
||||
pieces = if null pieces' then [""] else pieces'
|
||||
qs = map (TE.encodeUtf8 *** go) qs'
|
||||
|
||||
@ -1,37 +1,23 @@
|
||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module YesodCoreTest.ErrorHandling
|
||||
( errorHandlingTest
|
||||
, Widget
|
||||
, resourcesApp
|
||||
) where
|
||||
|
||||
import Data.Typeable(cast)
|
||||
import qualified System.Mem as Mem
|
||||
import qualified Control.Concurrent.Async as Async
|
||||
import Control.Concurrent as Conc
|
||||
import Yesod.Core
|
||||
import Test.Hspec
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Control.Exception (SomeException, try, AsyncException(..))
|
||||
import UnliftIO.Exception(finally)
|
||||
import Control.Exception (SomeException, try)
|
||||
import Network.HTTP.Types (Status, mkStatus)
|
||||
import Data.ByteString.Builder (Builder, toLazyByteString)
|
||||
import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
|
||||
import Data.Monoid (mconcat)
|
||||
import Data.Text (Text, pack)
|
||||
import Control.Monad (forM_)
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom
|
||||
import Control.Monad.Trans.State (StateT (..))
|
||||
import Control.Monad.Trans.Reader (ReaderT (..))
|
||||
import qualified UnliftIO.Exception as E
|
||||
import System.Timeout(timeout)
|
||||
import qualified Control.Exception.Lifted as E
|
||||
|
||||
data App = App
|
||||
|
||||
@ -51,15 +37,6 @@ mkYesod "App" [parseRoutes|
|
||||
/file-bad-name FileBadNameR GET
|
||||
|
||||
/good-builder GoodBuilderR GET
|
||||
|
||||
/auth-not-accepted AuthNotAcceptedR GET
|
||||
/auth-not-adequate AuthNotAdequateR GET
|
||||
/args-not-valid ArgsNotValidR POST
|
||||
/only-plain-text OnlyPlainTextR GET
|
||||
|
||||
/thread-killed ThreadKilledR GET
|
||||
/connection-closed-by-peer ConnectionClosedPeerR GET
|
||||
/sleep-sec SleepASecR GET
|
||||
|]
|
||||
|
||||
overrideStatus :: Status
|
||||
@ -121,28 +98,11 @@ getFileBadNameR :: Handler TypedContent
|
||||
getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing
|
||||
|
||||
goodBuilderContent :: Builder
|
||||
goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n"
|
||||
goodBuilderContent = mconcat $ replicate 100 $ fromByteString "This is a test\n"
|
||||
|
||||
getGoodBuilderR :: Handler TypedContent
|
||||
getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
|
||||
|
||||
-- this handler kills it's own thread
|
||||
getThreadKilledR :: Handler Html
|
||||
getThreadKilledR = do
|
||||
x <- liftIO Conc.myThreadId
|
||||
liftIO $ Async.withAsync (Conc.killThread x) Async.wait
|
||||
pure "unreachablle"
|
||||
getSleepASecR :: Handler Html
|
||||
getSleepASecR = do
|
||||
liftIO $ Conc.threadDelay 1000000
|
||||
pure "slept a second"
|
||||
|
||||
getConnectionClosedPeerR :: Handler Html
|
||||
getConnectionClosedPeerR = do
|
||||
x <- liftIO Conc.myThreadId
|
||||
liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait
|
||||
pure "unreachablle"
|
||||
|
||||
getErrorR :: Int -> Handler ()
|
||||
getErrorR 1 = setSession undefined "foo"
|
||||
getErrorR 2 = setSession "foo" undefined
|
||||
@ -154,19 +114,6 @@ getErrorR 7 = setLanguage undefined
|
||||
getErrorR 8 = cacheSeconds undefined
|
||||
getErrorR 9 = setUltDest (undefined :: Text)
|
||||
getErrorR 10 = setMessage undefined
|
||||
getErrorR x = error $ "getErrorR: " ++ show x
|
||||
|
||||
getAuthNotAcceptedR :: Handler TypedContent
|
||||
getAuthNotAcceptedR = notAuthenticated
|
||||
|
||||
getAuthNotAdequateR :: Handler TypedContent
|
||||
getAuthNotAdequateR = permissionDenied "That doesn't belong to you. "
|
||||
|
||||
postArgsNotValidR :: Handler TypedContent
|
||||
postArgsNotValidR = invalidArgs ["Doesn't matter.", "Don't want it."]
|
||||
|
||||
getOnlyPlainTextR :: Handler TypedContent
|
||||
getOnlyPlainTextR = selectRep $ provideRepType "text/plain" $ return ("Only plain text." :: Text)
|
||||
|
||||
errorHandlingTest :: Spec
|
||||
errorHandlingTest = describe "Test.ErrorHandling" $ do
|
||||
@ -181,15 +128,6 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
|
||||
it "file with bad name" caseFileBadName
|
||||
it "builder includes content-length" caseGoodBuilder
|
||||
forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i)
|
||||
it "accept DVI file, invalid args -> 400" caseDviInvalidArgs
|
||||
it "accept audio, not authenticated -> 401" caseAudioNotAuthenticated
|
||||
it "accept CSS, permission denied -> 403" caseCssPermissionDenied
|
||||
it "accept image, non-existent path -> 404" caseImageNotFound
|
||||
it "accept video, bad method -> 405" caseVideoBadMethod
|
||||
it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows
|
||||
it "custom config rethrows an exception" caseCustomExceptionRethrows
|
||||
it "thread killed rethrow" caseThreadKilledRethrow
|
||||
it "can timeout a runner" canTimeoutARunner
|
||||
|
||||
runner :: Session a -> IO a
|
||||
runner f = toWaiApp App >>= runSession f
|
||||
@ -277,100 +215,6 @@ caseGoodBuilder = runner $ do
|
||||
caseError :: Int -> IO ()
|
||||
caseError i = runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["error", pack $ show i] }
|
||||
ReaderT $ \r -> StateT $ \s -> runStateT (runReaderT (assertStatus 500 res) r) s `E.catch` \e -> do
|
||||
assertStatus 500 res `E.catch` \e -> do
|
||||
liftIO $ print res
|
||||
E.throwIO (e :: E.SomeException)
|
||||
|
||||
caseDviInvalidArgs :: IO ()
|
||||
caseDviInvalidArgs = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["args-not-valid"]
|
||||
, requestMethod = "POST"
|
||||
, requestHeaders =
|
||||
("accept", "application/x-dvi") : requestHeaders defaultRequest
|
||||
}
|
||||
assertStatus 400 res
|
||||
|
||||
caseAudioNotAuthenticated :: IO ()
|
||||
caseAudioNotAuthenticated = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["auth-not-accepted"]
|
||||
, requestHeaders =
|
||||
("accept", "audio/mpeg") : requestHeaders defaultRequest
|
||||
}
|
||||
assertStatus 401 res
|
||||
|
||||
caseCssPermissionDenied :: IO ()
|
||||
caseCssPermissionDenied = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["auth-not-adequate"]
|
||||
, requestHeaders =
|
||||
("accept", "text/css") : requestHeaders defaultRequest
|
||||
}
|
||||
assertStatus 403 res
|
||||
|
||||
caseImageNotFound :: IO ()
|
||||
caseImageNotFound = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["not_a_path"]
|
||||
, requestHeaders =
|
||||
("accept", "image/jpeg") : requestHeaders defaultRequest
|
||||
}
|
||||
assertStatus 404 res
|
||||
|
||||
caseVideoBadMethod :: IO ()
|
||||
caseVideoBadMethod = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["good-builder"]
|
||||
, requestMethod = "DELETE"
|
||||
, requestHeaders =
|
||||
("accept", "video/webm") : requestHeaders defaultRequest
|
||||
}
|
||||
assertStatus 405 res
|
||||
|
||||
fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e
|
||||
fromExceptionUnwrap se
|
||||
| Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e
|
||||
| Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e
|
||||
| otherwise = E.fromException se
|
||||
|
||||
|
||||
caseThreadKilledRethrow :: IO ()
|
||||
caseThreadKilledRethrow =
|
||||
shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
|
||||
(Just ThreadKilled) -> True
|
||||
_ -> False
|
||||
where
|
||||
testcode = runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["thread-killed"] }
|
||||
assertStatus 500 res
|
||||
assertBodyContains "Internal Server Error" res
|
||||
|
||||
caseDefaultConnectionCloseRethrows :: IO ()
|
||||
caseDefaultConnectionCloseRethrows =
|
||||
shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
|
||||
Just Warp.ConnectionClosedByPeer -> True
|
||||
_ -> False
|
||||
|
||||
where
|
||||
testcode = runner $ do
|
||||
_res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] }
|
||||
pure ()
|
||||
|
||||
caseCustomExceptionRethrows :: IO ()
|
||||
caseCustomExceptionRethrows =
|
||||
shouldThrow testcode $ \case Custom.MkMyException -> True
|
||||
where
|
||||
testcode = customAppRunner $ do
|
||||
_res <- request defaultRequest { pathInfo = ["throw-custom-exception"] }
|
||||
pure ()
|
||||
customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f
|
||||
|
||||
|
||||
canTimeoutARunner :: IO ()
|
||||
canTimeoutARunner = do
|
||||
res <- timeout 1000 $ runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["sleep-sec"] }
|
||||
assertStatus 200 res -- if 500, it's catching the timeout exception
|
||||
pure () -- it should've timeout by now, either being 500 or Nothing
|
||||
res `shouldBe` Nothing -- make sure that pure statement didn't happen.
|
||||
|
||||
@ -1,41 +0,0 @@
|
||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
|
||||
-- | a custom app that throws an exception
|
||||
module YesodCoreTest.ErrorHandling.CustomApp
|
||||
(CustomApp(..)
|
||||
, MyException(..)
|
||||
|
||||
-- * unused
|
||||
, Widget
|
||||
, resourcesCustomApp
|
||||
) where
|
||||
|
||||
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core
|
||||
import qualified UnliftIO.Exception as E
|
||||
|
||||
data CustomApp = CustomApp
|
||||
|
||||
mkYesod "CustomApp" [parseRoutes|
|
||||
/throw-custom-exception CustomHomeR GET
|
||||
|]
|
||||
|
||||
getCustomHomeR :: Handler Html
|
||||
getCustomHomeR =
|
||||
E.throwIO MkMyException
|
||||
|
||||
data MyException = MkMyException
|
||||
deriving (Show, E.Exception)
|
||||
|
||||
instance Yesod CustomApp where
|
||||
-- something we couldn't do before, rethrow custom exceptions
|
||||
catchHandlerExceptions _ action handler =
|
||||
action `E.catch` \exception -> do
|
||||
case E.fromException exception of
|
||||
Just MkMyException -> E.throwIO MkMyException
|
||||
Nothing -> handler exception
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user