merged master
This commit is contained in:
Casey Allred
commit
108c0c3984
29
.github/ISSUE_TEMPLATE.md
vendored
Normal file
29
.github/ISSUE_TEMPLATE.md
vendored
Normal file
@ -0,0 +1,29 @@
|
||||
<!---
|
||||
|
||||
### 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 list-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
Normal file
14
.github/PULL_REQUEST_TEMPLATE.md
vendored
Normal file
@ -0,0 +1,14 @@
|
||||
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 Haddock
|
||||
|
||||
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_-->
|
||||
48
.travis.yml
48
.travis.yml
@ -53,9 +53,9 @@ matrix:
|
||||
- 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=head HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
compiler: ": #GHC 8.0.1"
|
||||
addons: {apt: {packages: [cabal-install-head,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
|
||||
- env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
compiler: ": #GHC 8.0.2"
|
||||
addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
|
||||
|
||||
# Build with the newest GHC and cabal-install. This is an accepted failure,
|
||||
# see below.
|
||||
@ -69,20 +69,12 @@ matrix:
|
||||
compiler: ": #stack default"
|
||||
addons: {apt: {packages: [libgmp-dev]}}
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver lts-2"
|
||||
compiler: ": #stack 7.8.4"
|
||||
addons: {apt: {packages: [libgmp-dev]}}
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver lts-3"
|
||||
compiler: ": #stack 7.10.2"
|
||||
addons: {apt: {packages: [libgmp-dev]}}
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver lts-6"
|
||||
compiler: ": #stack 7.10.3"
|
||||
addons: {apt: {packages: [libgmp-dev]}}
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver lts-7"
|
||||
compiler: ": #stack 8.0.1"
|
||||
- env: BUILD=stack ARGS="--resolver lts-8"
|
||||
compiler: ": #stack 8.0.2"
|
||||
addons: {apt: {packages: [libgmp-dev]}}
|
||||
|
||||
# Nightly builds are allowed to fail
|
||||
@ -95,21 +87,12 @@ matrix:
|
||||
compiler: ": #stack default osx"
|
||||
os: osx
|
||||
|
||||
# Travis includes an OS X which is incompatible with GHC 7.8.4
|
||||
#- 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"
|
||||
- env: BUILD=stack ARGS="--resolver lts-8"
|
||||
compiler: ": #stack 8.0.2 osx"
|
||||
os: osx
|
||||
|
||||
- env: BUILD=stack ARGS="--resolver nightly"
|
||||
@ -119,6 +102,8 @@ matrix:
|
||||
allow_failures:
|
||||
- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
- env: BUILD=stack ARGS="--resolver nightly"
|
||||
- env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
- env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7
|
||||
|
||||
before_install:
|
||||
# Using compiler above sets CC to an invalid value, so unset it
|
||||
@ -154,9 +139,10 @@ install:
|
||||
- if [ -f configure.ac ]; then autoreconf -i; fi
|
||||
- |
|
||||
set -ex
|
||||
if [ "$RESOLVER" = "--resolver nightly" ]
|
||||
if [ "$ARGS" = "--resolver nightly" ]
|
||||
then
|
||||
stack $RESOLVER solver --update-config
|
||||
stack --install-ghc $ARGS build cabal-install
|
||||
stack --install-ghc $ARGS solver --update-config
|
||||
fi
|
||||
set +ex
|
||||
|
||||
@ -170,10 +156,16 @@ script:
|
||||
# Build dependencies with -O0 as well
|
||||
echo "apply-ghc-options: everything" >> stack.yaml
|
||||
|
||||
# Avoid OOM for building Cabal
|
||||
stack --install-ghc --no-terminal $ARGS build Cabal --fast
|
||||
|
||||
# Use slightly less intensive options on OS X due to Travis timeouts
|
||||
stack --no-terminal $ARGS test --fast --pedantic
|
||||
stack --install-ghc --no-terminal $ARGS test --fast
|
||||
else
|
||||
stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --pedantic
|
||||
# Avoid OOM for building Cabal
|
||||
stack --install-ghc --no-terminal $ARGS build Cabal --fast
|
||||
|
||||
stack --install-ghc --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --pedantic
|
||||
fi
|
||||
;;
|
||||
cabal)
|
||||
|
||||
95
CONTRIBUTING.md
Normal file
95
CONTRIBUTING.md
Normal file
@ -0,0 +1,95 @@
|
||||
# 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 Michael Snoyman, http://www.yesodweb.com/
|
||||
Copyright (c) 2012-2017 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
|
||||
|
||||
@ -1,6 +1,9 @@
|
||||
build: off
|
||||
|
||||
before_test:
|
||||
# http://help.appveyor.com/discussions/problems/6312-curl-command-not-found
|
||||
- set PATH=C:\Program Files\Git\mingw64\bin;%PATH%
|
||||
|
||||
- curl -sS -ostack.zip -L --insecure http://www.stackage.org/stack/windows-i386
|
||||
- 7z x stack.zip stack.exe
|
||||
|
||||
|
||||
19
stack.yaml
19
stack.yaml
@ -1,4 +1,4 @@
|
||||
resolver: lts-6.23
|
||||
resolver: lts-8.12
|
||||
packages:
|
||||
- ./yesod-core
|
||||
- ./yesod-static
|
||||
@ -13,20 +13,3 @@ packages:
|
||||
- ./yesod
|
||||
- ./yesod-eventsource
|
||||
- ./yesod-websockets
|
||||
|
||||
# Needed for LTS 2
|
||||
extra-deps:
|
||||
- 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
|
||||
|
||||
- conduit-extra-1.1.14
|
||||
- streaming-commons-0.1.16
|
||||
- typed-process-0.1.0.0
|
||||
- say-0.1.0.0
|
||||
- safe-exceptions-0.1.4.0
|
||||
- blaze-markup-0.7.1.0
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
## 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,5 +1,5 @@
|
||||
name: yesod-auth-oauth
|
||||
version: 1.4.1.1
|
||||
version: 1.4.2
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Hiromi Ishii
|
||||
@ -21,7 +21,7 @@ library
|
||||
cpp-options: -DGHC7
|
||||
else
|
||||
build-depends: base >= 4 && < 4.3
|
||||
build-depends: authenticate-oauth >= 1.5 && < 1.6
|
||||
build-depends: authenticate-oauth >= 1.5 && < 1.7
|
||||
, bytestring >= 0.9.1.4
|
||||
, yesod-core >= 1.4 && < 1.5
|
||||
, yesod-auth >= 1.4 && < 1.5
|
||||
|
||||
@ -1,11 +1,38 @@
|
||||
## 1.4.18
|
||||
## 1.4.21
|
||||
|
||||
* Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin
|
||||
|
||||
## 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
|
||||
|
||||
|
||||
@ -249,7 +249,8 @@ 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.
|
||||
-- 'maybeAuthIdRaw' for more information. The first call in a request
|
||||
-- does a database request to make sure that the account is still in the database.
|
||||
--
|
||||
-- Since 1.1.2
|
||||
defaultMaybeAuthId
|
||||
|
||||
@ -4,7 +4,7 @@
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE ScopedTypeVariables#-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
-- | A Yesod plugin for Authentication via e-mail
|
||||
--
|
||||
@ -106,6 +106,7 @@ module Yesod.Auth.Email
|
||||
, loginLinkKey
|
||||
, setLoginLinkKey
|
||||
-- * Default handlers
|
||||
, defaultEmailLoginHandler
|
||||
, defaultRegisterHandler
|
||||
, defaultForgotPasswordHandler
|
||||
, defaultSetPasswordHandler
|
||||
@ -115,10 +116,9 @@ import Yesod.Auth
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
import Yesod.Core
|
||||
import Yesod.Form
|
||||
import qualified Yesod.PasswordStore as PS
|
||||
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PS
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import qualified Crypto.Hash.MD5 as H
|
||||
import qualified Crypto.Hash as H
|
||||
import qualified Crypto.Nonce as Nonce
|
||||
import Data.ByteString.Base16 as B16
|
||||
import Data.Text (Text)
|
||||
@ -132,7 +132,8 @@ import Safe (readMay)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import qualified Text.Email.Validate
|
||||
import Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
|
||||
import Data.Maybe (isJust, isNothing, fromJust)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.ByteArray (convert)
|
||||
|
||||
loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
|
||||
loginR = PluginR "email" ["login"]
|
||||
@ -202,6 +203,22 @@ class ( YesodAuth site
|
||||
-- @since 1.1.0
|
||||
setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO ()
|
||||
|
||||
-- | Hash and salt a password
|
||||
--
|
||||
-- Default: 'saltPass'.
|
||||
--
|
||||
-- @since 1.4.20
|
||||
hashAndSaltPassword :: Text -> HandlerT site IO SaltedPass
|
||||
hashAndSaltPassword = liftIO . saltPass
|
||||
|
||||
-- | Verify a password matches the stored password for the given account.
|
||||
--
|
||||
-- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'.
|
||||
--
|
||||
-- @since 1.4.20
|
||||
verifyPassword :: Text -> SaltedPass -> HandlerT site IO Bool
|
||||
verifyPassword plain salted = return $ isValidPass plain salted
|
||||
|
||||
-- | Verify the email address on the given account.
|
||||
--
|
||||
-- __/Warning!/__ If you have persisted the @'AuthEmailId' site@
|
||||
@ -290,6 +307,17 @@ class ( YesodAuth site
|
||||
normalizeEmailAddress :: site -> Text -> Text
|
||||
normalizeEmailAddress _ = TS.toLower
|
||||
|
||||
-- | Handler called to render the login page.
|
||||
-- The default works fine, but you may want to override it in
|
||||
-- order to have a different DOM.
|
||||
--
|
||||
-- Default: 'defaultEmailLoginHandler'.
|
||||
--
|
||||
-- @since 1.4.17
|
||||
emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO ()
|
||||
emailLoginHandler = defaultEmailLoginHandler
|
||||
|
||||
|
||||
-- | Handler called to render the registration page. The
|
||||
-- default works fine, but you may want to override it in
|
||||
-- order to have a different DOM.
|
||||
@ -346,8 +374,11 @@ authEmail =
|
||||
getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
|
||||
getRegisterR = registerHandler
|
||||
|
||||
emailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO ()
|
||||
emailLoginHandler toParent = do
|
||||
-- | Default implementation of 'emailLoginHandler'.
|
||||
--
|
||||
-- @since 1.4.17
|
||||
defaultEmailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO ()
|
||||
defaultEmailLoginHandler toParent = do
|
||||
(widget, enctype) <- liftWidgetT $ generateFormPost loginForm
|
||||
|
||||
[whamlet|
|
||||
@ -402,6 +433,7 @@ emailLoginHandler toParent = do
|
||||
langs <- languages
|
||||
master <- getYesod
|
||||
return $ renderAuthMessage master langs msg
|
||||
|
||||
-- | Default implementation of 'registerHandler'.
|
||||
--
|
||||
-- @since 1.2.6
|
||||
@ -518,7 +550,7 @@ defaultForgotPasswordHandler = do
|
||||
where
|
||||
forgotPasswordForm extra = do
|
||||
(emailRes, emailView) <- mreq emailField emailSettings Nothing
|
||||
|
||||
|
||||
let forgotPasswordRes = ForgotPasswordForm <$> emailRes
|
||||
let widget = do
|
||||
[whamlet|
|
||||
@ -604,12 +636,14 @@ postLoginR = do
|
||||
, emailCredsStatus <$> mecreds
|
||||
) of
|
||||
(Just aid, Just email', Just True) -> do
|
||||
mrealpass <- lift $ getPassword aid
|
||||
case mrealpass of
|
||||
Nothing -> return Nothing
|
||||
Just realpass -> return $ if isValidPass pass realpass
|
||||
then Just email'
|
||||
else Nothing
|
||||
mrealpass <- lift $ getPassword aid
|
||||
case mrealpass of
|
||||
Nothing -> return Nothing
|
||||
Just realpass -> do
|
||||
passValid <- lift $ verifyPassword pass realpass
|
||||
return $ if passValid
|
||||
then Just email'
|
||||
else Nothing
|
||||
_ -> return Nothing
|
||||
let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
|
||||
case maid of
|
||||
@ -737,14 +771,16 @@ postPasswordR = do
|
||||
then getThird jcreds
|
||||
else fcurrent
|
||||
mrealpass <- lift $ getPassword aid
|
||||
case mrealpass of
|
||||
Nothing ->
|
||||
case (mrealpass, current) of
|
||||
(Nothing, _) ->
|
||||
lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
|
||||
Just realpass
|
||||
| isNothing current -> loginErrorMessageI LoginR Msg.BadSetPass
|
||||
| isValidPass (fromJust current) realpass -> confirmPassword aid tm jcreds
|
||||
| otherwise ->
|
||||
lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
|
||||
(_, Nothing) ->
|
||||
loginErrorMessageI LoginR Msg.BadSetPass
|
||||
(Just realpass, Just current') -> do
|
||||
passValid <- lift $ verifyPassword current' realpass
|
||||
if passValid
|
||||
then confirmPassword aid tm jcreds
|
||||
else lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
|
||||
|
||||
where
|
||||
msgOk = Msg.PassUpdated
|
||||
@ -771,7 +807,7 @@ postPasswordR = do
|
||||
case isSecure of
|
||||
Left e -> lift $ loginErrorMessage (tm setpassR) e
|
||||
Right () -> do
|
||||
salted <- liftIO $ saltPass new
|
||||
salted <- lift $ hashAndSaltPassword new
|
||||
y <- lift $ do
|
||||
setPassword aid salted
|
||||
deleteSession loginLinkKey
|
||||
@ -795,7 +831,7 @@ saltPass = fmap (decodeUtf8With lenientDecode)
|
||||
|
||||
saltPass' :: String -> String -> String
|
||||
saltPass' salt pass =
|
||||
salt ++ T.unpack (TE.decodeUtf8 $ B16.encode $ H.hash $ TE.encodeUtf8 $ T.pack $ salt ++ pass)
|
||||
salt ++ T.unpack (TE.decodeUtf8 $ B16.encode $ convert (H.hash (TE.encodeUtf8 $ T.pack $ salt ++ pass) :: H.Digest H.MD5))
|
||||
|
||||
isValidPass :: Text -- ^ cleartext password
|
||||
-> SaltedPass -- ^ salted password
|
||||
|
||||
@ -74,7 +74,11 @@ 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)
|
||||
|
||||
@ -19,6 +19,7 @@ module Yesod.Auth.Message
|
||||
, russianMessage
|
||||
, dutchMessage
|
||||
, danishMessage
|
||||
, koreanMessage
|
||||
) where
|
||||
|
||||
import Data.Monoid (mappend, (<>))
|
||||
@ -75,9 +76,9 @@ defaultMessage = englishMessage
|
||||
|
||||
englishMessage :: AuthMessage -> Text
|
||||
englishMessage NoOpenID = "No OpenID identifier found"
|
||||
englishMessage LoginOpenID = "Login via OpenID"
|
||||
englishMessage LoginGoogle = "Login via Google"
|
||||
englishMessage LoginYahoo = "Login via Yahoo"
|
||||
englishMessage LoginOpenID = "Log in via OpenID"
|
||||
englishMessage LoginGoogle = "Log in via Google"
|
||||
englishMessage LoginYahoo = "Log in via Yahoo"
|
||||
englishMessage Email = "Email"
|
||||
englishMessage UserName = "User name"
|
||||
englishMessage Password = "Password"
|
||||
@ -101,8 +102,8 @@ englishMessage NewPass = "New password"
|
||||
englishMessage ConfirmPass = "Confirm"
|
||||
englishMessage PassMismatch = "Passwords did not match, please try again"
|
||||
englishMessage PassUpdated = "Password updated"
|
||||
englishMessage Facebook = "Login with Facebook"
|
||||
englishMessage LoginViaEmail = "Login via email"
|
||||
englishMessage Facebook = "Log in with Facebook"
|
||||
englishMessage LoginViaEmail = "Log in via email"
|
||||
englishMessage InvalidLogin = "Invalid login"
|
||||
englishMessage NowLoggedIn = "You are now logged in"
|
||||
englishMessage LoginTitle = "Log In"
|
||||
@ -174,7 +175,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" -- FIXME by Google Translate "user name"
|
||||
spanishMessage UserName = "Nombre de Usuario"
|
||||
spanishMessage Password = "Contraseña"
|
||||
spanishMessage CurrentPassword = "Contraseña actual"
|
||||
spanishMessage Register = "Registrarse"
|
||||
@ -205,9 +206,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 = "Contraseña actualizada"
|
||||
spanishMessage PasswordResetTitle = "Actualización de contraseña"
|
||||
spanishMessage ProvideIdentifier = "Cuenta de correo o nombre de usuario"
|
||||
spanishMessage SendPasswordResetEmail = "Correo de actualización de contraseña enviado"
|
||||
spanishMessage SendPasswordResetEmail = "Enviar correo de actualización de contraseña"
|
||||
spanishMessage PasswordResetPrompt = "Escriba su cuenta de correo o nombre de usuario, y una confirmación de actualización de contraseña será enviada a su cuenta de correo."
|
||||
spanishMessage InvalidUsernamePass = "Combinación de nombre de usuario/contraseña invalida"
|
||||
-- TODO
|
||||
@ -416,7 +417,7 @@ japaneseMessage LoginYahoo = "Yahooでログイン"
|
||||
japaneseMessage Email = "Eメール"
|
||||
japaneseMessage UserName = "ユーザー名" -- FIXME by Google Translate "user name"
|
||||
japaneseMessage Password = "パスワード"
|
||||
japaneseMessage CurrentPassword = "Current password"
|
||||
japaneseMessage CurrentPassword = "現在のパスワード"
|
||||
japaneseMessage Register = "登録"
|
||||
japaneseMessage RegisterLong = "新規アカウント登録"
|
||||
japaneseMessage EnterEmail = "メールアドレスを入力してください。確認メールが送られます"
|
||||
@ -511,9 +512,9 @@ chineseMessage LoginOpenID = "用OpenID登录"
|
||||
chineseMessage LoginGoogle = "用Google帐户登录"
|
||||
chineseMessage LoginYahoo = "用Yahoo帐户登录"
|
||||
chineseMessage Email = "邮箱"
|
||||
chineseMessage UserName = "用户名" -- FIXME by Google Translate "user name"
|
||||
chineseMessage UserName = "用户名"
|
||||
chineseMessage Password = "密码"
|
||||
chineseMessage CurrentPassword = "Current password"
|
||||
chineseMessage CurrentPassword = "当前密码"
|
||||
chineseMessage Register = "注册"
|
||||
chineseMessage RegisterLong = "注册新帐户"
|
||||
chineseMessage EnterEmail = "输入你的邮箱地址，你将收到一封确认邮件。"
|
||||
@ -547,11 +548,10 @@ chineseMessage ProvideIdentifier = "邮箱或用户名"
|
||||
chineseMessage SendPasswordResetEmail = "发送密码重置邮件"
|
||||
chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。"
|
||||
chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"
|
||||
-- TODO
|
||||
chineseMessage i@(IdentifierNotFound _) = englishMessage i
|
||||
chineseMessage Logout = "註銷" -- FIXME by Google Translate
|
||||
chineseMessage LogoutTitle = "註銷" -- FIXME by Google Translate
|
||||
chineseMessage AuthError = "验证错误" -- FIXME by Google Translate
|
||||
chineseMessage (IdentifierNotFound ident) = "邮箱/用户名不存在: " `mappend` ident
|
||||
chineseMessage Logout = "注销"
|
||||
chineseMessage LogoutTitle = "注销"
|
||||
chineseMessage AuthError = "验证错误"
|
||||
|
||||
czechMessage :: AuthMessage -> Text
|
||||
czechMessage NoOpenID = "Nebyl nalezen identifikátor OpenID"
|
||||
@ -785,3 +785,50 @@ 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 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 = "인증오류"
|
||||
|
||||
@ -1,13 +1,8 @@
|
||||
{-# LANGUAGE OverloadedStrings, BangPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- |
|
||||
-- Module : Crypto.PasswordStore
|
||||
-- Copyright : (c) Peter Scott, 2011
|
||||
-- License : BSD-style
|
||||
--
|
||||
-- Maintainer : pjscott@iastate.edu
|
||||
-- Stability : experimental
|
||||
-- Portability : portable
|
||||
-- This is a fork of pwstore-fast, originally copyright (c) Peter Scott, 2011,
|
||||
-- and released under a BSD-style licence.
|
||||
--
|
||||
-- Securely store hashed, salted passwords. If you need to store and verify
|
||||
-- passwords, there are many wrong ways to do it, most of them all too
|
||||
@ -70,8 +65,10 @@
|
||||
-- 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.PasswordStore (
|
||||
module Yesod.Auth.Util.PasswordStore (
|
||||
|
||||
-- * Algorithms
|
||||
pbkdf1, -- :: ByteString -> Salt -> Int -> ByteString
|
||||
@ -102,16 +99,14 @@ module Yesod.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)
|
||||
@ -120,6 +115,7 @@ import System.IO
|
||||
import System.Random
|
||||
import Data.Maybe
|
||||
import qualified Control.Exception
|
||||
import Data.ByteArray (convert)
|
||||
|
||||
---------------------
|
||||
-- Cryptographic base
|
||||
@ -132,16 +128,23 @@ import qualified Control.Exception
|
||||
-- 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 = H.finalize $ H.init `H.update` password `H.update` salt
|
||||
where
|
||||
first_hash =
|
||||
convert $
|
||||
((CH.hashFinalize $ CH.hashInit `CH.hashUpdate` password `CH.hashUpdate` salt) :: CH.Digest CH.SHA256)
|
||||
|
||||
|
||||
-- | Hash a 'ByteString' for a given number of rounds. The number of rounds is 0
|
||||
-- or more. If the number of rounds specified is 0, the ByteString will be
|
||||
-- returned unmodified.
|
||||
hashRounds :: ByteString -> Int -> ByteString
|
||||
hashRounds (!bs) 0 = bs
|
||||
hashRounds bs rounds = hashRounds (H.hash bs) (rounds - 1)
|
||||
hashRounds bs rounds = hashRounds (convert (CH.hash bs :: CH.Digest CH.SHA256)) (rounds - 1)
|
||||
|
||||
-- | Computes the hmacSHA256 of the given message, with the given 'Salt'.
|
||||
hmacSHA256 :: ByteString
|
||||
@ -151,13 +154,16 @@ hmacSHA256 :: ByteString
|
||||
-> ByteString
|
||||
-- ^ The encoded message
|
||||
hmacSHA256 secret msg =
|
||||
toBytes (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)
|
||||
convert (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)
|
||||
|
||||
-- | PBKDF2 key-derivation function.
|
||||
-- For details see @http://tools.ietf.org/html/rfc2898@.
|
||||
-- @32@ is the most common digest size for @SHA256@, and is
|
||||
-- what the algorithm internally uses.
|
||||
-- @HMAC+SHA256@ is used as @PRF@, because @HMAC+SHA1@ is considered too weak.
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
pbkdf2 :: ByteString -> Salt -> Int -> ByteString
|
||||
pbkdf2 password (SaltBS salt) c =
|
||||
let hLen = 32
|
||||
@ -196,6 +202,9 @@ 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
|
||||
@ -249,6 +258,9 @@ 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
|
||||
|
||||
@ -257,6 +269,8 @@ makePassword = makePasswordWith pbkdf1
|
||||
--
|
||||
-- >>> makePasswordWith pbkdf1 "password" 14
|
||||
--
|
||||
-- @since 1.4.18
|
||||
--
|
||||
makePasswordWith :: (ByteString -> Salt -> Int -> ByteString)
|
||||
-- ^ The algorithm to use (e.g. pbkdf1)
|
||||
-> ByteString
|
||||
@ -273,6 +287,9 @@ 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)
|
||||
@ -293,6 +310,9 @@ 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^)
|
||||
|
||||
@ -309,6 +329,8 @@ 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)
|
||||
@ -325,6 +347,9 @@ 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^)
|
||||
|
||||
@ -338,6 +363,9 @@ 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
|
||||
@ -352,6 +380,9 @@ 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
|
||||
@ -365,12 +396,18 @@ 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 =
|
||||
@ -379,17 +416,26 @@ 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
|
||||
|
||||
@ -397,6 +443,9 @@ 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 = []
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-auth
|
||||
version: 1.4.18
|
||||
version: 1.4.21
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman, Patrick Brisbin
|
||||
@ -27,7 +27,8 @@ library
|
||||
, wai >= 1.4
|
||||
, template-haskell
|
||||
, base16-bytestring
|
||||
, cryptohash
|
||||
, cryptonite
|
||||
, memory
|
||||
, random >= 1.0.0.2
|
||||
, text >= 0.7
|
||||
, mime-mail >= 0.3
|
||||
@ -37,8 +38,8 @@ library
|
||||
, unordered-containers
|
||||
, yesod-form >= 1.4 && < 1.5
|
||||
, transformers >= 0.2.2
|
||||
, persistent >= 2.1 && < 2.7
|
||||
, persistent-template >= 2.1 && < 2.7
|
||||
, persistent >= 2.1 && < 2.8
|
||||
, persistent-template >= 2.1 && < 2.8
|
||||
, http-client
|
||||
, http-conduit >= 2.1
|
||||
, aeson >= 0.7
|
||||
@ -76,8 +77,8 @@ library
|
||||
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
|
||||
|
||||
@ -5,9 +5,13 @@ 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)
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as TIO
|
||||
import Distribution.PackageDescription.Parse (readPackageDescription)
|
||||
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
|
||||
import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)
|
||||
import Distribution.Verbosity (normal)
|
||||
import System.Directory (getDirectoryContents, doesFileExist)
|
||||
import Control.Monad (unless)
|
||||
|
||||
@ -31,7 +35,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
|
||||
checked <- checkRoute route cabal
|
||||
let routePair = case checked of
|
||||
Left err@EmptyRoute -> (error . show) err
|
||||
Left err@RouteCaseError -> (error . show) err
|
||||
@ -54,7 +58,7 @@ addHandlerInteractive = do
|
||||
putStr "Name of route (without trailing R): "
|
||||
hFlush stdout
|
||||
name <- getLine
|
||||
checked <- checkRoute name
|
||||
checked <- checkRoute name cabal
|
||||
case checked of
|
||||
Left err@EmptyRoute -> (error . show) err
|
||||
Left err@RouteCaseError -> print err >> routeInput
|
||||
@ -75,7 +79,9 @@ addHandlerInteractive = do
|
||||
|
||||
addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO ()
|
||||
addHandlerFiles cabal (name, handlerFile) pattern methods = do
|
||||
modify "Application.hs" $ fixApp name
|
||||
src <- getSrcDir cabal
|
||||
let applicationFile = concat [src, "/Application.hs"]
|
||||
modify applicationFile $ fixApp name
|
||||
modify cabal $ fixCabal name
|
||||
modify "config/routes" $ fixRoutes name pattern methods
|
||||
writeFile handlerFile $ mkHandler name pattern methods
|
||||
@ -94,15 +100,16 @@ getCabal = do
|
||||
[] -> error "No cabal file found"
|
||||
_ -> error "Too many cabal files found"
|
||||
|
||||
checkRoute :: String -> IO (Either RouteError (String, FilePath))
|
||||
checkRoute name =
|
||||
checkRoute :: String -> FilePath -> IO (Either RouteError (String, FilePath))
|
||||
checkRoute name cabal =
|
||||
case name of
|
||||
[] -> return $ Left EmptyRoute
|
||||
c:_
|
||||
| isLower c -> return $ Left RouteCaseError
|
||||
| otherwise -> do
|
||||
-- Check that the handler file doesn't already exist
|
||||
let handlerFile = concat ["Handler/", name, ".hs"]
|
||||
src <- getSrcDir cabal
|
||||
let handlerFile = concat [src, "/Handler/", name, ".hs"]
|
||||
exists <- doesFileExist handlerFile
|
||||
if exists
|
||||
then (return . Left . RouteExists) handlerFile
|
||||
@ -214,3 +221,10 @@ mkHandler name pattern methods = unlines
|
||||
uncapitalize :: String -> String
|
||||
uncapitalize (x:xs) = toLower x : xs
|
||||
uncapitalize "" = ""
|
||||
|
||||
getSrcDir :: FilePath -> IO FilePath
|
||||
getSrcDir cabal = do
|
||||
pd <- flattenPackageDescription <$> readPackageDescription normal cabal
|
||||
let buildInfo = allBuildInfo pd
|
||||
srcDirs = concatMap hsSourceDirs buildInfo
|
||||
return $ fromMaybe "." $ listToMaybe srcDirs
|
||||
|
||||
@ -1,3 +1,31 @@
|
||||
## 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,3 +1,4 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
@ -14,6 +15,7 @@ import Control.Concurrent.STM
|
||||
import qualified Control.Exception.Safe as Ex
|
||||
import Control.Monad (forever, unless, void,
|
||||
when)
|
||||
import Data.ByteString (ByteString, isInfixOf)
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Conduit (($$), (=$))
|
||||
import qualified Data.Conduit.Binary as CB
|
||||
@ -21,6 +23,7 @@ import qualified Data.Conduit.List as CL
|
||||
import Data.Default.Class (def)
|
||||
import Data.FileEmbed (embedFile)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (isJust)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Streaming.Network (bindPortTCP,
|
||||
bindRandomPortTCP)
|
||||
@ -125,6 +128,7 @@ reverseProxy :: DevelOpts -> TVar Int -> IO ()
|
||||
reverseProxy opts appPortVar = do
|
||||
manager <- newManager $ managerSetProxy noProxy tlsManagerSettings
|
||||
let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")]
|
||||
sayV = when (verbose opts) . sayString
|
||||
let onExc _ req
|
||||
| maybe False (("application/json" `elem`) . parseHttpAccept)
|
||||
(lookup "accept" $ requestHeaders req) =
|
||||
@ -141,6 +145,7 @@ reverseProxy opts appPortVar = do
|
||||
let proxyApp = waiProxyToSettings
|
||||
(const $ do
|
||||
appPort <- atomically $ readTVar appPortVar
|
||||
sayV $ "revProxy: appPort " ++ (show appPort)
|
||||
return $
|
||||
ReverseProxy.WPRProxyDest
|
||||
$ ProxyDest "127.0.0.1" appPort)
|
||||
@ -221,12 +226,40 @@ checkDevelFile =
|
||||
then return x
|
||||
else loop xs
|
||||
|
||||
stackSuccessString :: ByteString
|
||||
stackSuccessString = "ExitSuccess"
|
||||
|
||||
stackFailureString :: ByteString
|
||||
stackFailureString = "ExitFailure"
|
||||
|
||||
-- We need updateAppPort logic to prevent a race condition.
|
||||
-- See https://github.com/yesodweb/yesod/issues/1380
|
||||
updateAppPort :: ByteString -> TVar Bool -- ^ Bool to indicate if the
|
||||
-- output from stack has
|
||||
-- started. False indicate
|
||||
-- that it hasn't started
|
||||
-- yet.
|
||||
-> TVar Int -> STM ()
|
||||
updateAppPort bs buildStarted appPortVar = do
|
||||
hasStarted <- readTVar buildStarted
|
||||
let buildEnd = isInfixOf stackFailureString bs || isInfixOf stackSuccessString bs
|
||||
case (hasStarted, buildEnd) of
|
||||
(False, False) -> do
|
||||
writeTVar appPortVar (-1 :: Int)
|
||||
writeTVar buildStarted True
|
||||
(True, False) -> return ()
|
||||
(_, True) -> writeTVar buildStarted False
|
||||
|
||||
-- | Get the set of all flags available in the given cabal file
|
||||
getAvailableFlags :: D.GenericPackageDescription -> Set.Set String
|
||||
getAvailableFlags =
|
||||
Set.fromList . map (unFlagName . D.flagName) . D.genPackageFlags
|
||||
where
|
||||
#if MIN_VERSION_Cabal(2, 0, 0)
|
||||
unFlagName = D.unFlagName
|
||||
#else
|
||||
unFlagName (D.FlagName fn) = fn
|
||||
#endif
|
||||
|
||||
-- | This is the main entry point. Run the devel server.
|
||||
devel :: DevelOpts -- ^ command line options
|
||||
@ -247,9 +280,20 @@ devel opts passThroughArgs = do
|
||||
#else
|
||||
cabal <- D.findPackageDesc "."
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_Cabal(2, 0, 0)
|
||||
gpd <- D.readGenericPackageDescription D.normal cabal
|
||||
#else
|
||||
gpd <- D.readPackageDescription D.normal cabal
|
||||
#endif
|
||||
|
||||
let pd = D.packageDescription gpd
|
||||
D.PackageIdentifier (D.PackageName packageName) _version = D.package pd
|
||||
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
|
||||
@ -282,6 +326,7 @@ devel opts passThroughArgs = do
|
||||
sayV = when (verbose opts) . sayString
|
||||
|
||||
-- Leverage "stack build --file-watch" to do the build
|
||||
runStackBuild :: TVar Int -> [Char] -> Set.Set [Char] -> IO ()
|
||||
runStackBuild appPortVar packageName availableFlags = do
|
||||
-- We call into this app for the devel-signal command
|
||||
myPath <- getExecutablePath
|
||||
@ -315,7 +360,7 @@ devel opts passThroughArgs = do
|
||||
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
|
||||
@ -324,12 +369,13 @@ devel opts passThroughArgs = do
|
||||
withProcess_ procConfig $ \p -> do
|
||||
let helper getter h =
|
||||
getter p
|
||||
$$ CL.iterM (\_ -> atomically $ writeTVar appPortVar (-1))
|
||||
$$ CL.iterM (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
|
||||
=$ CB.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.
|
||||
@ -352,6 +398,7 @@ devel opts passThroughArgs = do
|
||||
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
|
||||
@ -362,9 +409,11 @@ devel opts passThroughArgs = do
|
||||
|
||||
sayV "First successful build complete, running app"
|
||||
|
||||
-- We're going to set the PORT and DISPLAY_PORT variables
|
||||
-- for the child below
|
||||
-- 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
|
||||
@ -405,7 +454,26 @@ devel opts passThroughArgs = do
|
||||
, "Main.main"
|
||||
]
|
||||
-}
|
||||
let procDef = setStdin closed $ setEnv env' $ proc "stack"
|
||||
|
||||
-- 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
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-bin
|
||||
version: 1.5.1
|
||||
version: 1.5.2.6
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -33,7 +33,7 @@ executable yesod
|
||||
, template-haskell
|
||||
, directory >= 1.2.1
|
||||
, Cabal >= 1.18
|
||||
, unix-compat >= 0.2 && < 0.5
|
||||
, unix-compat >= 0.2
|
||||
, containers >= 0.2
|
||||
, attoparsec >= 0.10
|
||||
, http-types >= 0.7
|
||||
|
||||
@ -1,3 +1,43 @@
|
||||
## 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`
|
||||
|
||||
@ -10,7 +10,7 @@ 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.Handler (sendWaiApplication, stripHandlerT)
|
||||
import Yesod.Core.Class.Yesod
|
||||
import Yesod.Core.Class.Handler
|
||||
|
||||
@ -28,6 +28,15 @@ instance YesodSubDispatch WaiSubsite master where
|
||||
where
|
||||
WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
|
||||
|
||||
instance YesodSubDispatch WaiSubsiteWithAuth (HandlerT master IO) where
|
||||
yesodSubDispatch YesodSubRunnerEnv {..} req =
|
||||
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req
|
||||
where
|
||||
base = stripHandlerT handlert ysreGetSub ysreToParentRoute route
|
||||
route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []
|
||||
WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
|
||||
handlert = sendWaiApplication $ set
|
||||
|
||||
-- | A helper function for creating YesodSubDispatch instances, used by the
|
||||
-- internal generated code. This function has been exported since 1.4.11.
|
||||
-- It promotes a subsite handler to a wai application.
|
||||
|
||||
@ -66,7 +66,8 @@ 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)
|
||||
#if MIN_VERSION_aeson(1, 0, 0)
|
||||
#elif MIN_VERSION_aeson(0, 7, 0)
|
||||
import Data.Aeson.Encode (encodeToTextBuilder)
|
||||
#else
|
||||
import Data.Aeson.Encode (fromValue)
|
||||
@ -242,6 +243,11 @@ instance ToContent a => ToContent (DontFullyEvaluate a) where
|
||||
toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a
|
||||
|
||||
instance ToContent J.Value where
|
||||
#if MIN_VERSION_aeson(1, 0, 0)
|
||||
toContent = flip ContentBuilder Nothing
|
||||
. J.fromEncoding
|
||||
. J.toEncoding
|
||||
#else
|
||||
toContent = flip ContentBuilder Nothing
|
||||
. Blaze.fromLazyText
|
||||
. toLazyText
|
||||
@ -251,6 +257,8 @@ instance ToContent J.Value where
|
||||
. fromValue
|
||||
#endif
|
||||
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_aeson(0, 11, 0)
|
||||
instance ToContent J.Encoding where
|
||||
toContent = flip ContentBuilder Nothing . J.fromEncoding
|
||||
|
||||
@ -34,6 +34,7 @@ module Yesod.Core.Dispatch
|
||||
, defaultMiddlewaresNoLogging
|
||||
-- * WAI subsites
|
||||
, WaiSubsite (..)
|
||||
, WaiSubsiteWithAuth (..)
|
||||
, subHelper
|
||||
) where
|
||||
|
||||
|
||||
@ -10,6 +10,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.Handler
|
||||
@ -31,6 +32,7 @@ module Yesod.Core.Handler
|
||||
, getsYesod
|
||||
, getUrlRender
|
||||
, getUrlRenderParams
|
||||
, getPostParams
|
||||
, getCurrentRoute
|
||||
, getRequest
|
||||
, waiRequest
|
||||
@ -113,6 +115,7 @@ module Yesod.Core.Handler
|
||||
, deleteCookie
|
||||
, addHeader
|
||||
, setHeader
|
||||
, replaceOrAddHeader
|
||||
, setLanguage
|
||||
-- ** Content caching and expiration
|
||||
, cacheSeconds
|
||||
@ -120,6 +123,7 @@ module Yesod.Core.Handler
|
||||
, alreadyExpired
|
||||
, expiresAt
|
||||
, setEtag
|
||||
, setWeakEtag
|
||||
-- * Session
|
||||
, SessionMap
|
||||
, lookupSession
|
||||
@ -205,7 +209,7 @@ import Control.Monad.Trans.Class (lift)
|
||||
|
||||
import Data.Aeson (ToJSON(..))
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
|
||||
import Data.Text.Encoding (decodeUtf8With, encodeUtf8, decodeUtf8)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
|
||||
@ -238,7 +242,7 @@ import Yesod.Core.Types
|
||||
import Yesod.Routes.Class (Route)
|
||||
import Blaze.ByteString.Builder (Builder)
|
||||
import Safe (headMay)
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.CaseInsensitive (CI, original)
|
||||
import qualified Data.Conduit.List as CL
|
||||
import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)
|
||||
import qualified System.PosixCompat.Files as PC
|
||||
@ -339,6 +343,18 @@ getUrlRenderParams
|
||||
=> m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
|
||||
getUrlRenderParams = rheRender <$> askHandlerEnv
|
||||
|
||||
-- | Get all the post parameters passed to the handler. To also get
|
||||
-- the submitted files (if any), you have to use 'runRequestBody'
|
||||
-- instead of this function.
|
||||
--
|
||||
-- @since 1.4.33
|
||||
getPostParams
|
||||
:: MonadHandler m
|
||||
=> m [(Text, Text)]
|
||||
getPostParams = do
|
||||
reqBodyContent <- runRequestBody
|
||||
return $ fst reqBodyContent
|
||||
|
||||
-- | Get the route requested by the user. If this is a 404 response- where the
|
||||
-- user requested an invalid route- this function will return 'Nothing'.
|
||||
getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
|
||||
@ -425,7 +441,7 @@ handlerToIO =
|
||||
-- Uses 'handlerToIO', liftResourceT, and resourceForkIO
|
||||
-- for correctness and efficiency
|
||||
--
|
||||
-- Since 1.2.8
|
||||
-- @since 1.2.8
|
||||
forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler
|
||||
-> HandlerT site IO ()
|
||||
-> HandlerT site IO ()
|
||||
@ -617,7 +633,7 @@ sendResponseStatus s = handlerError . HCContent s . toTypedContent
|
||||
-- | Bypass remaining handler code and output the given JSON with the given
|
||||
-- status code.
|
||||
--
|
||||
-- Since 1.4.18
|
||||
-- @since 1.4.18
|
||||
sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a
|
||||
#if MIN_VERSION_aeson(0, 11, 0)
|
||||
sendStatusJSON s v = sendResponseStatus s (toEncoding v)
|
||||
@ -642,7 +658,7 @@ sendWaiResponse = handlerError . HCWai
|
||||
|
||||
-- | Switch over to handling the current request with a WAI @Application@.
|
||||
--
|
||||
-- Since 1.2.17
|
||||
-- @since 1.2.17
|
||||
sendWaiApplication :: MonadHandler m => W.Application -> m b
|
||||
sendWaiApplication = handlerError . HCWaiApp
|
||||
|
||||
@ -650,7 +666,7 @@ sendWaiApplication = handlerError . HCWaiApp
|
||||
-- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw
|
||||
-- responses (e.g., Warp).
|
||||
--
|
||||
-- Since 1.2.16
|
||||
-- @since 1.2.16
|
||||
sendRawResponseNoConduit
|
||||
:: (MonadHandler m, MonadBaseControl IO m)
|
||||
=> (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
|
||||
@ -666,7 +682,7 @@ sendRawResponseNoConduit raw = control $ \runInIO ->
|
||||
-- WAI 2.1 or later, and a web server which supports raw responses (e.g.,
|
||||
-- Warp).
|
||||
--
|
||||
-- Since 1.2.7
|
||||
-- @since 1.2.7
|
||||
sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
|
||||
=> (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())
|
||||
-> m a
|
||||
@ -685,7 +701,7 @@ sendRawResponse raw = control $ \runInIO ->
|
||||
-- | Send a 304 not modified response immediately. This is a short-circuiting
|
||||
-- action.
|
||||
--
|
||||
-- Since 1.4.4
|
||||
-- @since 1.4.4
|
||||
notModified :: MonadHandler m => m a
|
||||
notModified = sendWaiResponse $ W.responseBuilder H.status304 [] mempty
|
||||
|
||||
@ -765,7 +781,7 @@ setLanguage = setSession langKey
|
||||
-- Note that, while the data type used here is 'Text', you must provide only
|
||||
-- ASCII value to be HTTP compliant.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
addHeader :: MonadHandler m => Text -> Text -> m ()
|
||||
addHeader a = addHeaderInternal . Header (encodeUtf8 a) . encodeUtf8
|
||||
|
||||
@ -774,6 +790,40 @@ setHeader :: MonadHandler m => Text -> Text -> m ()
|
||||
setHeader = addHeader
|
||||
{-# DEPRECATED setHeader "Please use addHeader instead" #-}
|
||||
|
||||
-- | Replace an existing header with a new value or add a new header
|
||||
-- if not present.
|
||||
--
|
||||
-- Note that, while the data type used here is 'Text', you must provide only
|
||||
-- ASCII value to be HTTP compliant.
|
||||
--
|
||||
-- @since 1.4.36
|
||||
replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()
|
||||
replaceOrAddHeader a b =
|
||||
modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)}
|
||||
where
|
||||
repHeader = Header (encodeUtf8 a) (encodeUtf8 b)
|
||||
|
||||
sameHeaderName :: Header -> Header -> Bool
|
||||
sameHeaderName (Header n1 _) (Header n2 _) = T.toLower (decodeUtf8 n1) == T.toLower (decodeUtf8 n2)
|
||||
sameHeaderName _ _ = False
|
||||
|
||||
replaceIndividualHeader :: [Header] -> [Header]
|
||||
replaceIndividualHeader [] = [repHeader]
|
||||
replaceIndividualHeader xs = aux xs []
|
||||
where
|
||||
aux [] acc = acc ++ [repHeader]
|
||||
aux (x:xs') acc =
|
||||
if sameHeaderName repHeader x
|
||||
then acc ++
|
||||
[repHeader] ++
|
||||
(filter (\header -> not (sameHeaderName header repHeader)) xs')
|
||||
else aux xs' (acc ++ [x])
|
||||
|
||||
replaceHeader :: Endo [Header] -> Endo [Header]
|
||||
replaceHeader endo =
|
||||
let allHeaders :: [Header] = appEndo endo []
|
||||
in Endo (\rest -> replaceIndividualHeader allHeaders ++ rest)
|
||||
|
||||
-- | Set the Cache-Control header to indicate this response should be cached
|
||||
-- for the given number of seconds.
|
||||
cacheSeconds :: MonadHandler m => Int -> m ()
|
||||
@ -802,35 +852,78 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
|
||||
expiresAt :: MonadHandler m => UTCTime -> m ()
|
||||
expiresAt = setHeader "Expires" . formatRFC1123
|
||||
|
||||
data Etag
|
||||
= WeakEtag !S.ByteString
|
||||
-- ^ Prefixed by W/ and surrounded in quotes. Signifies that contents are
|
||||
-- semantically identical but make no guarantees about being bytewise identical.
|
||||
| StrongEtag !S.ByteString
|
||||
-- ^ Signifies that contents should be byte-for-byte identical if they match
|
||||
-- the provided ETag
|
||||
| InvalidEtag !S.ByteString
|
||||
-- ^ Anything else that ends up in a header that expects an ETag but doesn't
|
||||
-- properly follow the ETag format specified in RFC 7232, section 2.3
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | Check the if-none-match header and, if it matches the given value, return
|
||||
-- a 304 not modified response. Otherwise, set the etag header to the given
|
||||
-- value.
|
||||
--
|
||||
-- Note that it is the responsibility of the caller to ensure that the provided
|
||||
-- value is a value etag value, no sanity checking is performed by this
|
||||
-- value is a valid etag value, no sanity checking is performed by this
|
||||
-- function.
|
||||
--
|
||||
-- Since 1.4.4
|
||||
-- @since 1.4.4
|
||||
setEtag :: MonadHandler m => Text -> m ()
|
||||
setEtag etag = do
|
||||
mmatch <- lookupHeader "if-none-match"
|
||||
let matches = maybe [] parseMatch mmatch
|
||||
if encodeUtf8 etag `elem` matches
|
||||
baseTag = encodeUtf8 etag
|
||||
strongTag = StrongEtag baseTag
|
||||
badTag = InvalidEtag baseTag
|
||||
if any (\tag -> tag == strongTag || tag == badTag) matches
|
||||
then notModified
|
||||
else addHeader "etag" $ T.concat ["\"", etag, "\""]
|
||||
|
||||
-- | Parse an if-none-match field according to the spec. Does not parsing on
|
||||
-- weak matches, which are not supported by setEtag.
|
||||
parseMatch :: S.ByteString -> [S.ByteString]
|
||||
|
||||
-- | Parse an if-none-match field according to the spec.
|
||||
parseMatch :: S.ByteString -> [Etag]
|
||||
parseMatch =
|
||||
map clean . S.split W8._comma
|
||||
where
|
||||
clean = stripQuotes . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace
|
||||
clean = classify . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace
|
||||
|
||||
stripQuotes bs
|
||||
classify bs
|
||||
| S.length bs >= 2 && S.head bs == W8._quotedbl && S.last bs == W8._quotedbl
|
||||
= S.init $ S.tail bs
|
||||
| otherwise = bs
|
||||
= StrongEtag $ S.init $ S.tail bs
|
||||
| S.length bs >= 4 &&
|
||||
S.head bs == W8._W &&
|
||||
S.index bs 1 == W8._slash &&
|
||||
S.index bs 2 == W8._quotedbl &&
|
||||
S.last bs == W8._quotedbl
|
||||
= WeakEtag $ S.init $ S.drop 3 bs
|
||||
| otherwise = InvalidEtag bs
|
||||
|
||||
-- | Check the if-none-match header and, if it matches the given value, return
|
||||
-- a 304 not modified response. Otherwise, set the etag header to the given
|
||||
-- value.
|
||||
--
|
||||
-- A weak etag is only expected to be semantically identical to the prior content,
|
||||
-- but doesn't have to be byte-for-byte identical. Therefore it can be useful for
|
||||
-- dynamically generated content that may be difficult to perform bytewise hashing
|
||||
-- upon.
|
||||
--
|
||||
-- Note that it is the responsibility of the caller to ensure that the provided
|
||||
-- value is a valid etag value, no sanity checking is performed by this
|
||||
-- function.
|
||||
--
|
||||
-- @since 1.4.37
|
||||
setWeakEtag :: MonadHandler m => Text -> m ()
|
||||
setWeakEtag etag = do
|
||||
mmatch <- lookupHeader "if-none-match"
|
||||
let matches = maybe [] parseMatch mmatch
|
||||
if WeakEtag (encodeUtf8 etag) `elem` matches
|
||||
then notModified
|
||||
else addHeader "etag" $ T.concat ["W/\"", etag, "\""]
|
||||
|
||||
-- | Set a variable in the user's session.
|
||||
--
|
||||
@ -856,7 +949,7 @@ deleteSession = modify . modSession . Map.delete
|
||||
|
||||
-- | Clear all session variables.
|
||||
--
|
||||
-- Since: 1.0.1
|
||||
-- @since: 1.0.1
|
||||
clearSession :: MonadHandler m => m ()
|
||||
clearSession = modify $ \x -> x { ghsSession = Map.empty }
|
||||
|
||||
@ -896,7 +989,7 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map k
|
||||
--
|
||||
-- > redirect (NewsfeedR :#: storyId)
|
||||
--
|
||||
-- Since 1.2.9.
|
||||
-- @since 1.2.9.
|
||||
data Fragment a b = a :#: b deriving (Show, Typeable)
|
||||
|
||||
instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where
|
||||
@ -960,7 +1053,7 @@ hamletToRepHtml = withUrlRenderer
|
||||
|
||||
-- | Deprecated synonym for 'withUrlRenderer'.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
giveUrlRenderer :: MonadHandler m
|
||||
=> ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
|
||||
-> m output
|
||||
@ -970,7 +1063,7 @@ giveUrlRenderer = withUrlRenderer
|
||||
-- | Provide a URL rendering function to the given function and return the
|
||||
-- result. Useful for processing Shakespearean templates.
|
||||
--
|
||||
-- Since 1.2.20
|
||||
-- @since 1.2.20
|
||||
withUrlRenderer :: MonadHandler m
|
||||
=> ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
|
||||
-> m output
|
||||
@ -986,7 +1079,7 @@ getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)
|
||||
=> m (message -> Text)
|
||||
getMessageRender = do
|
||||
env <- askHandlerEnv
|
||||
l <- reqLangs <$> getRequest
|
||||
l <- languages
|
||||
return $ renderMessage (rheSite env) l
|
||||
|
||||
-- | Use a per-request cache to avoid performing the same action multiple times.
|
||||
@ -998,7 +1091,7 @@ getMessageRender = do
|
||||
--
|
||||
-- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
cached :: (MonadHandler m, Typeable a)
|
||||
=> m a
|
||||
-> m a
|
||||
@ -1022,7 +1115,7 @@ cached action = do
|
||||
-- You can turn those parameters into a ByteString cache key.
|
||||
-- For example, caching a lookup of a Link by a token where multiple token lookups might be performed.
|
||||
--
|
||||
-- Since 1.4.0
|
||||
-- @since 1.4.0
|
||||
cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a
|
||||
cachedBy k action = do
|
||||
cache <- ghsCacheBy <$> get
|
||||
@ -1037,15 +1130,15 @@ cachedBy k action = do
|
||||
|
||||
-- | Get the list of supported languages supplied by the user.
|
||||
--
|
||||
-- Languages are determined based on the following three (in descending order
|
||||
-- Languages are determined based on the following (in descending order
|
||||
-- of preference):
|
||||
--
|
||||
-- * The _LANG user session variable.
|
||||
--
|
||||
-- * The _LANG get parameter.
|
||||
--
|
||||
-- * The _LANG cookie.
|
||||
--
|
||||
-- * The _LANG user session variable.
|
||||
--
|
||||
-- * Accept-Language HTTP header.
|
||||
--
|
||||
-- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates.
|
||||
@ -1063,13 +1156,13 @@ lookup' a = map snd . filter (\x -> a == fst x)
|
||||
|
||||
-- | Lookup a request header.
|
||||
--
|
||||
-- Since 1.2.2
|
||||
-- @since 1.2.2
|
||||
lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString)
|
||||
lookupHeader = fmap listToMaybe . lookupHeaders
|
||||
|
||||
-- | Lookup a request header.
|
||||
--
|
||||
-- Since 1.2.2
|
||||
-- @since 1.2.2
|
||||
lookupHeaders :: MonadHandler m => CI S8.ByteString -> m [S8.ByteString]
|
||||
lookupHeaders key = do
|
||||
req <- waiRequest
|
||||
@ -1078,7 +1171,7 @@ lookupHeaders key = do
|
||||
-- | Lookup basic authentication data from __Authorization__ header of
|
||||
-- request. Returns user name and password
|
||||
--
|
||||
-- Since 1.4.9
|
||||
-- @since 1.4.9
|
||||
lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text))
|
||||
lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization")
|
||||
where
|
||||
@ -1088,7 +1181,7 @@ lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization")
|
||||
-- | Lookup bearer authentication datafrom __Authorization__ header of
|
||||
-- request. Returns bearer token value
|
||||
--
|
||||
-- Since 1.4.9
|
||||
-- @since 1.4.9
|
||||
lookupBearerAuth :: (MonadHandler m) => m (Maybe Text)
|
||||
lookupBearerAuth = fmap (>>= getBR)
|
||||
(lookupHeader "Authorization")
|
||||
@ -1162,7 +1255,7 @@ lookupCookies pn = do
|
||||
-- | Select a representation to send to the client based on the representations
|
||||
-- provided inside this do-block. Should be used together with 'provideRep'.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
selectRep :: MonadHandler m
|
||||
=> Writer.Writer (Endo [ProvidedRep m]) ()
|
||||
-> m TypedContent
|
||||
@ -1218,13 +1311,13 @@ selectRep w = do
|
||||
|
||||
-- | Internal representation of a single provided representation.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
data ProvidedRep m = ProvidedRep !ContentType !(m Content)
|
||||
|
||||
-- | Provide a single representation to be used, based on the request of the
|
||||
-- client. Should be used together with 'selectRep'.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
provideRep :: (Monad m, HasContentType a)
|
||||
=> m a
|
||||
-> Writer.Writer (Endo [ProvidedRep m]) ()
|
||||
@ -1237,7 +1330,7 @@ provideRep handler = provideRepType (getContentType handler) handler
|
||||
--
|
||||
-- > provideRepType "application/x-special-format" "This is the content"
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
provideRepType :: (Monad m, ToContent a)
|
||||
=> ContentType
|
||||
-> m a
|
||||
@ -1247,7 +1340,7 @@ provideRepType ct handler =
|
||||
|
||||
-- | Stream in the raw request body without any parsing.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
rawRequestBody :: MonadHandler m => Source m S.ByteString
|
||||
rawRequestBody = do
|
||||
req <- lift waiRequest
|
||||
@ -1267,7 +1360,7 @@ fileSource = transPipe liftResourceT . fileSourceRaw
|
||||
--
|
||||
-- > respond ct = return . TypedContent ct . toContent
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent
|
||||
respond ct = return . TypedContent ct . toContent
|
||||
|
||||
@ -1279,7 +1372,7 @@ respond ct = return . TypedContent ct . toContent
|
||||
-- actions make no sense here. For example: short-circuit responses, setting
|
||||
-- headers, changing status codes, etc.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
respondSource :: ContentType
|
||||
-> Source (HandlerT site IO) (Flush Builder)
|
||||
-> HandlerT site IO TypedContent
|
||||
@ -1293,44 +1386,44 @@ respondSource ctype src = HandlerT $ \hd ->
|
||||
-- | In a streaming response, send a single chunk of data. This function works
|
||||
-- on most datatypes, such as @ByteString@ and @Html@.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
sendChunk :: Monad m => ToFlushBuilder a => a -> Producer m (Flush Builder)
|
||||
sendChunk = yield . toFlushBuilder
|
||||
|
||||
-- | In a streaming response, send a flush command, causing all buffered data
|
||||
-- to be immediately sent to the client.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
sendFlush :: Monad m => Producer m (Flush Builder)
|
||||
sendFlush = yield Flush
|
||||
|
||||
-- | Type-specialized version of 'sendChunk' for strict @ByteString@s.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
sendChunkBS :: Monad m => S.ByteString -> Producer m (Flush Builder)
|
||||
sendChunkBS = sendChunk
|
||||
|
||||
-- | Type-specialized version of 'sendChunk' for lazy @ByteString@s.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
sendChunkLBS :: Monad m => L.ByteString -> Producer m (Flush Builder)
|
||||
sendChunkLBS = sendChunk
|
||||
|
||||
-- | Type-specialized version of 'sendChunk' for strict @Text@s.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
sendChunkText :: Monad m => T.Text -> Producer m (Flush Builder)
|
||||
sendChunkText = sendChunk
|
||||
|
||||
-- | Type-specialized version of 'sendChunk' for lazy @Text@s.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder)
|
||||
sendChunkLazyText = sendChunk
|
||||
|
||||
-- | Type-specialized version of 'sendChunk' for @Html@s.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
-- @since 1.2.0
|
||||
sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)
|
||||
sendChunkHtml = sendChunk
|
||||
|
||||
@ -1374,7 +1467,7 @@ stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do
|
||||
|
||||
-- | The default cookie name for the CSRF token ("XSRF-TOKEN").
|
||||
--
|
||||
-- Since 1.4.14
|
||||
-- @since 1.4.14
|
||||
defaultCsrfCookieName :: S8.ByteString
|
||||
defaultCsrfCookieName = "XSRF-TOKEN"
|
||||
|
||||
@ -1382,7 +1475,7 @@ defaultCsrfCookieName = "XSRF-TOKEN"
|
||||
--
|
||||
-- The cookie's path is set to @/@, making it valid for your whole website.
|
||||
--
|
||||
-- Since 1.4.14
|
||||
-- @since 1.4.14
|
||||
setCsrfCookie :: MonadHandler m => m ()
|
||||
setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieName, setCookiePath = Just "/" }
|
||||
|
||||
@ -1390,7 +1483,7 @@ setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieN
|
||||
--
|
||||
-- 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
|
||||
-- @since 1.4.14
|
||||
setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m ()
|
||||
setCsrfCookieWithCookie cookie = do
|
||||
mCsrfToken <- reqToken <$> getRequest
|
||||
@ -1398,70 +1491,79 @@ setCsrfCookieWithCookie cookie = do
|
||||
|
||||
-- | The default header name for the CSRF token ("X-XSRF-TOKEN").
|
||||
--
|
||||
-- Since 1.4.14
|
||||
-- @since 1.4.14
|
||||
defaultCsrfHeaderName :: CI S8.ByteString
|
||||
defaultCsrfHeaderName = "X-XSRF-TOKEN"
|
||||
|
||||
-- | Takes a header name to lookup a CSRF token. If the value doesn't match the token stored in the session,
|
||||
-- this function throws a 'PermissionDenied' error.
|
||||
--
|
||||
-- Since 1.4.14
|
||||
-- @since 1.4.14
|
||||
checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m ()
|
||||
checkCsrfHeaderNamed headerName = do
|
||||
valid <- hasValidCsrfHeaderNamed headerName
|
||||
unless valid (permissionDenied csrfErrorMessage)
|
||||
(valid, mHeader) <- hasValidCsrfHeaderNamed' headerName
|
||||
unless valid (permissionDenied $ csrfErrorMessage [CSRFHeader (decodeUtf8 $ original headerName) mHeader])
|
||||
|
||||
-- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session.
|
||||
--
|
||||
-- Since 1.4.14
|
||||
-- @since 1.4.14
|
||||
hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool
|
||||
hasValidCsrfHeaderNamed headerName = do
|
||||
hasValidCsrfHeaderNamed headerName = fst <$> hasValidCsrfHeaderNamed' headerName
|
||||
|
||||
-- | Like 'hasValidCsrfHeaderNamed', but also returns the header value to be used in error messages.
|
||||
hasValidCsrfHeaderNamed' :: MonadHandler m => CI S8.ByteString -> m (Bool, Maybe Text)
|
||||
hasValidCsrfHeaderNamed' headerName = do
|
||||
mCsrfToken <- reqToken <$> getRequest
|
||||
mXsrfHeader <- lookupHeader headerName
|
||||
|
||||
return $ validCsrf mCsrfToken mXsrfHeader
|
||||
return $ (validCsrf mCsrfToken mXsrfHeader, decodeUtf8 <$> mXsrfHeader)
|
||||
|
||||
-- CSRF Parameter checking
|
||||
|
||||
-- | The default parameter name for the CSRF token ("_token")
|
||||
--
|
||||
-- Since 1.4.14
|
||||
-- @since 1.4.14
|
||||
defaultCsrfParamName :: Text
|
||||
defaultCsrfParamName = "_token"
|
||||
|
||||
-- | Takes a POST parameter name to lookup a CSRF token. If the value doesn't match the token stored in the session,
|
||||
-- this function throws a 'PermissionDenied' error.
|
||||
--
|
||||
-- Since 1.4.14
|
||||
-- @since 1.4.14
|
||||
checkCsrfParamNamed :: MonadHandler m => Text -> m ()
|
||||
checkCsrfParamNamed paramName = do
|
||||
valid <- hasValidCsrfParamNamed paramName
|
||||
unless valid (permissionDenied csrfErrorMessage)
|
||||
(valid, mParam) <- hasValidCsrfParamNamed' paramName
|
||||
unless valid (permissionDenied $ csrfErrorMessage [CSRFParam paramName mParam])
|
||||
|
||||
-- | Takes a POST parameter name to lookup a CSRF token, and returns whether the value matches the token stored in the session.
|
||||
--
|
||||
-- Since 1.4.14
|
||||
-- @since 1.4.14
|
||||
hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool
|
||||
hasValidCsrfParamNamed paramName = do
|
||||
hasValidCsrfParamNamed paramName = fst <$> hasValidCsrfParamNamed' paramName
|
||||
|
||||
-- | Like 'hasValidCsrfParamNamed', but also returns the param value to be used in error messages.
|
||||
hasValidCsrfParamNamed' :: MonadHandler m => Text -> m (Bool, Maybe Text)
|
||||
hasValidCsrfParamNamed' paramName = do
|
||||
mCsrfToken <- reqToken <$> getRequest
|
||||
mCsrfParam <- lookupPostParam paramName
|
||||
|
||||
return $ validCsrf mCsrfToken (encodeUtf8 <$> mCsrfParam)
|
||||
return $ (validCsrf mCsrfToken (encodeUtf8 <$> mCsrfParam), mCsrfParam)
|
||||
|
||||
-- | Checks that a valid CSRF token is present in either the request headers or POST parameters.
|
||||
-- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error.
|
||||
--
|
||||
-- Since 1.4.14
|
||||
-- @since 1.4.14
|
||||
checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m)
|
||||
=> CI S8.ByteString -- ^ The header name to lookup the CSRF token
|
||||
-> Text -- ^ The POST parameter name to lookup the CSRF token
|
||||
-> m ()
|
||||
checkCsrfHeaderOrParam headerName paramName = do
|
||||
validHeader <- hasValidCsrfHeaderNamed headerName
|
||||
validParam <- hasValidCsrfParamNamed paramName
|
||||
(validHeader, mHeader) <- hasValidCsrfHeaderNamed' headerName
|
||||
(validParam, mParam) <- hasValidCsrfParamNamed' paramName
|
||||
unless (validHeader || validParam) $ do
|
||||
$logWarnS "yesod-core" csrfErrorMessage
|
||||
permissionDenied csrfErrorMessage
|
||||
let errorMessage = csrfErrorMessage $ [CSRFHeader (decodeUtf8 $ original headerName) mHeader, CSRFParam paramName mParam]
|
||||
$logWarnS "yesod-core" errorMessage
|
||||
permissionDenied errorMessage
|
||||
|
||||
validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool
|
||||
-- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.
|
||||
@ -1469,5 +1571,25 @@ validCsrf (Just token) (Just param) = encodeUtf8 token `constEqBytes` param
|
||||
validCsrf Nothing _param = True
|
||||
validCsrf (Just _token) Nothing = False
|
||||
|
||||
csrfErrorMessage :: Text
|
||||
csrfErrorMessage = "A valid CSRF token wasn't present in HTTP headers or POST parameters. Because the request could have been forged, it's been rejected altogether. Check the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection."
|
||||
data CSRFExpectation = CSRFHeader Text (Maybe Text) -- Key/Value
|
||||
| CSRFParam Text (Maybe Text) -- Key/Value
|
||||
|
||||
csrfErrorMessage :: [CSRFExpectation]
|
||||
-> Text -- ^ Error message
|
||||
csrfErrorMessage expectedLocations = T.intercalate "\n"
|
||||
[ "A valid CSRF token wasn't present. Because the request could have been forged, it's been rejected altogether."
|
||||
, "If you're a developer of this site, these tips will help you debug the issue:"
|
||||
, "- Read the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection."
|
||||
, "- Check that your HTTP client is persisting cookies between requests, like a browser does."
|
||||
, "- By default, the CSRF token is sent to the client in a cookie named " `mappend` (decodeUtf8 defaultCsrfCookieName) `mappend` "."
|
||||
, "- The server is looking for the token in the following locations:\n" `mappend` T.intercalate "\n" (map csrfLocation expectedLocations)
|
||||
]
|
||||
|
||||
where csrfLocation expected = case expected of
|
||||
CSRFHeader k v -> T.intercalate " " [" - An HTTP header named", k, (formatValue v)]
|
||||
CSRFParam k v -> T.intercalate " " [" - A POST parameter named", k, (formatValue v)]
|
||||
|
||||
formatValue :: Maybe Text -> Text
|
||||
formatValue maybeText = case maybeText of
|
||||
Nothing -> "(which is not currently set)"
|
||||
Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"]
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Core.Internal.TH where
|
||||
|
||||
import Prelude hiding (exp)
|
||||
@ -15,12 +16,18 @@ import Language.Haskell.TH.Syntax
|
||||
import qualified Network.Wai as W
|
||||
|
||||
import Data.ByteString.Lazy.Char8 ()
|
||||
#if MIN_VERSION_base(4,8,0)
|
||||
import Data.List (foldl', uncons)
|
||||
#else
|
||||
import Data.List (foldl')
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad (replicateM, void)
|
||||
import Data.Either (partitionEithers)
|
||||
import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)
|
||||
import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
|
||||
|
||||
import Yesod.Routes.TH
|
||||
import Yesod.Routes.Parse
|
||||
@ -55,8 +62,40 @@ 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
|
||||
let (name', rest, cxt) = case parse parseName "" name of
|
||||
Left err -> error $ show err
|
||||
Right a -> a
|
||||
fst <$> mkYesodGeneral' cxt name' (fmap Left rest) isSub return res
|
||||
|
||||
where
|
||||
parseName = do
|
||||
cxt <- option [] parseContext
|
||||
name' <- parseWord
|
||||
args <- many parseWord
|
||||
spaces
|
||||
eof
|
||||
return ( name', args, cxt)
|
||||
|
||||
parseWord = do
|
||||
spaces
|
||||
many1 alphaNum
|
||||
|
||||
parseContext = try $ do
|
||||
cxts <- parseParen parseContexts
|
||||
spaces
|
||||
_ <- string "=>"
|
||||
return cxts
|
||||
|
||||
parseParen p = do
|
||||
spaces
|
||||
_ <- char '('
|
||||
r <- p
|
||||
spaces
|
||||
_ <- char ')'
|
||||
return r
|
||||
|
||||
parseContexts =
|
||||
sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
|
||||
|
||||
-- | See 'mkYesodData'.
|
||||
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
|
||||
@ -80,7 +119,23 @@ mkYesodGeneral :: String -- ^ foundation type
|
||||
-> (Exp -> Q Exp) -- ^ unwrap handler
|
||||
-> [ResourceTree String]
|
||||
-> Q([Dec],[Dec])
|
||||
mkYesodGeneral namestr args isSub f resS = do
|
||||
mkYesodGeneral = mkYesodGeneral' []
|
||||
|
||||
mkYesodGeneral' :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
|
||||
-> String -- ^ foundation type
|
||||
-> [Either String [String]] -- ^ arguments for the type
|
||||
-> Bool -- ^ is this a subsite
|
||||
-> (Exp -> Q Exp) -- ^ unwrap handler
|
||||
-> [ResourceTree String]
|
||||
-> Q([Dec],[Dec])
|
||||
mkYesodGeneral' appCxt' namestr args isSub f resS = do
|
||||
let appCxt = fmap (\(c:rest) ->
|
||||
#if MIN_VERSION_template_haskell(2,10,0)
|
||||
foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
|
||||
#else
|
||||
ClassP (mkName c) $ fmap nameToType rest
|
||||
#endif
|
||||
) appCxt'
|
||||
mname <- lookupTypeName namestr
|
||||
arity <- case mname of
|
||||
Just name -> do
|
||||
@ -105,10 +160,13 @@ mkYesodGeneral namestr args isSub f resS = do
|
||||
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) ->
|
||||
foldr (\arg (xs,vns',cs) ->
|
||||
case arg of
|
||||
Left t -> ( ConT (mkName t):xs, n:ns, cs )
|
||||
Right ts -> ( VarT n :xs, ns
|
||||
Left t ->
|
||||
( nameToType t:xs, vns', cs )
|
||||
Right ts ->
|
||||
let (n, ns) = maybe (error "mkYesodGeneral: Should be unreachable.") id $ uncons vns' in
|
||||
( VarT n : xs, ns
|
||||
, fmap (\t ->
|
||||
#if MIN_VERSION_template_haskell(2,10,0)
|
||||
AppT (ConT $ mkName t) (VarT n)
|
||||
@ -118,11 +176,11 @@ mkYesodGeneral namestr args isSub f resS = do
|
||||
) ts ++ cs )
|
||||
) ([],vns,[]) args
|
||||
site = foldl' AppT (ConT name) argtypes
|
||||
res = map (fmap parseType) resS
|
||||
renderRouteDec <- mkRenderRouteInstance site res
|
||||
routeAttrsDec <- mkRouteAttrsInstance site res
|
||||
res = map (fmap (parseType . dropBracket)) resS
|
||||
renderRouteDec <- mkRenderRouteInstance' appCxt site res
|
||||
routeAttrsDec <- mkRouteAttrsInstance' appCxt site res
|
||||
dispatchDec <- mkDispatchInstance site cxt f res
|
||||
parse <- mkParseRouteInstance site res
|
||||
parseRoute <- mkParseRouteInstance' appCxt site res
|
||||
let rname = mkName $ "resources" ++ namestr
|
||||
eres <- lift resS
|
||||
let resourcesDec =
|
||||
@ -130,7 +188,7 @@ mkYesodGeneral namestr args isSub f resS = do
|
||||
, FunD rname [Clause [] (NormalB eres) []]
|
||||
]
|
||||
let dataDec = concat
|
||||
[ [parse]
|
||||
[ [parseRoute]
|
||||
, renderRouteDec
|
||||
, [routeAttrsDec]
|
||||
, resourcesDec
|
||||
@ -138,6 +196,12 @@ mkYesodGeneral namestr args isSub f resS = do
|
||||
]
|
||||
return (dataDec, dispatchDec)
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
where
|
||||
uncons (h:t) = Just (h,t)
|
||||
uncons _ = Nothing
|
||||
#endif
|
||||
|
||||
mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
|
||||
mkMDS f rh = MkDispatchSettings
|
||||
{ mdsRunHandler = rh
|
||||
|
||||
@ -175,9 +175,14 @@ type BottomOfHeadAsync master
|
||||
|
||||
type Texts = [Text]
|
||||
|
||||
-- | Wrap up a normal WAI application as a Yesod subsite.
|
||||
-- | Wrap up a normal WAI application as a Yesod subsite. Ignore parent site's middleware and isAuthorized.
|
||||
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 site = RunHandlerEnv
|
||||
{ rheRender :: !(Route site -> [(Text, Text)] -> Text)
|
||||
, rheRoute :: !(Maybe (Route site))
|
||||
@ -560,6 +565,14 @@ 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
|
||||
|
||||
@ -10,10 +10,12 @@ module Yesod.Routes.Parse
|
||||
, parseType
|
||||
, parseTypeTree
|
||||
, TypeTree (..)
|
||||
, dropBracket
|
||||
, nameToType
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Char (isUpper)
|
||||
import Data.Char (isUpper, isLower, isSpace)
|
||||
import Language.Haskell.TH.Quote
|
||||
import qualified System.IO as SIO
|
||||
import Yesod.Routes.TH
|
||||
@ -86,7 +88,7 @@ resourcesFromString =
|
||||
spaces = takeWhile (== ' ') thisLine
|
||||
(others, remainder) = parse indent otherLines'
|
||||
(this, otherLines') =
|
||||
case takeWhile (not . isPrefixOf "--") $ words thisLine of
|
||||
case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of
|
||||
(pattern:rest0)
|
||||
| Just (constr:rest) <- stripColonLast rest0
|
||||
, Just attrs <- mapM parseAttr rest ->
|
||||
@ -102,6 +104,26 @@ 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)
|
||||
@ -181,7 +203,7 @@ parseTypeTree :: String -> Maybe TypeTree
|
||||
parseTypeTree orig =
|
||||
toTypeTree pieces
|
||||
where
|
||||
pieces = filter (not . null) $ splitOn '-' $ addDashes orig
|
||||
pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig
|
||||
addDashes [] = []
|
||||
addDashes (x:xs) =
|
||||
front $ addDashes xs
|
||||
@ -194,7 +216,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
|
||||
@ -232,14 +254,18 @@ toTypeTree orig = do
|
||||
gos' (front . (t:)) xs'
|
||||
|
||||
ttToType :: TypeTree -> Type
|
||||
ttToType (TTTerm s) = ConT $ mkName s
|
||||
ttToType (TTTerm s) = nameToType s
|
||||
ttToType (TTApp x y) = ttToType x `AppT` ttToType y
|
||||
ttToType (TTList t) = ListT `AppT` ttToType t
|
||||
|
||||
nameToType :: String -> Type
|
||||
nameToType t@(h:_) | isLower h = VarT $ mkName t
|
||||
nameToType t = ConT $ mkName t
|
||||
|
||||
pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
|
||||
pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
|
||||
pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652
|
||||
pieceFromString ('#':x) = Right $ (True, Dynamic x)
|
||||
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) = Left (False, x)
|
||||
pieceFromString ('+':'!':x) = Left (False, x)
|
||||
@ -252,3 +278,10 @@ 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
|
||||
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
module Yesod.Routes.TH.ParseRoute
|
||||
( -- ** ParseRoute
|
||||
mkParseRouteInstance
|
||||
, mkParseRouteInstance'
|
||||
) where
|
||||
|
||||
import Yesod.Routes.TH.Types
|
||||
@ -12,7 +13,10 @@ import Yesod.Routes.Class
|
||||
import Yesod.Routes.TH.Dispatch
|
||||
|
||||
mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
|
||||
mkParseRouteInstance typ ress = do
|
||||
mkParseRouteInstance = mkParseRouteInstance' []
|
||||
|
||||
mkParseRouteInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
|
||||
mkParseRouteInstance' cxt typ ress = do
|
||||
cls <- mkDispatchClause
|
||||
MkDispatchSettings
|
||||
{ mdsRunHandler = [|\_ _ x _ -> x|]
|
||||
@ -28,7 +32,7 @@ mkParseRouteInstance 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 [] (ConT ''ParseRoute `AppT` typ)
|
||||
return $ instanceD cxt (ConT ''ParseRoute `AppT` typ)
|
||||
[ FunD 'parseRoute $ return $ Clause
|
||||
[]
|
||||
(NormalB $ fixer `AppE` VarE helper)
|
||||
|
||||
@ -12,6 +12,9 @@ import Yesod.Routes.TH.Types
|
||||
import Language.Haskell.TH (conT)
|
||||
#endif
|
||||
import Language.Haskell.TH.Syntax
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
import Data.Bits (xor)
|
||||
#endif
|
||||
import Data.Maybe (maybeToList)
|
||||
import Control.Monad (replicateM)
|
||||
import Data.Text (pack)
|
||||
@ -156,18 +159,28 @@ mkRenderRouteInstance' cxt typ ress = do
|
||||
cls <- mkRenderRouteClauses ress
|
||||
(cons, decs) <- mkRouteCons ress
|
||||
#if MIN_VERSION_template_haskell(2,12,0)
|
||||
did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT clazzes)
|
||||
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)
|
||||
#elif MIN_VERSION_template_haskell(2,11,0)
|
||||
did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes
|
||||
did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)
|
||||
let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
|
||||
#else
|
||||
let did = DataInstD [] ''Route [typ] cons clazzes
|
||||
let did = DataInstD [] ''Route [typ] cons clazzes'
|
||||
let sds = []
|
||||
#endif
|
||||
return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)
|
||||
[ did
|
||||
, FunD (mkName "renderRoute") cls
|
||||
] : decs
|
||||
]
|
||||
: sds ++ decs
|
||||
where
|
||||
clazzes = [''Show, ''Eq, ''Read]
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
clazzes standalone = if standalone `xor` null cxt then
|
||||
clazzes'
|
||||
else
|
||||
[]
|
||||
#endif
|
||||
clazzes' = [''Show, ''Eq, ''Read]
|
||||
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
notStrict :: Bang
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Yesod.Routes.TH.RouteAttrs
|
||||
( mkRouteAttrsInstance
|
||||
, mkRouteAttrsInstance'
|
||||
) where
|
||||
|
||||
import Yesod.Routes.TH.Types
|
||||
@ -15,9 +16,12 @@ import Control.Applicative ((<$>))
|
||||
#endif
|
||||
|
||||
mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
|
||||
mkRouteAttrsInstance typ ress = do
|
||||
mkRouteAttrsInstance = mkRouteAttrsInstance' []
|
||||
|
||||
mkRouteAttrsInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
|
||||
mkRouteAttrsInstance' cxt typ ress = do
|
||||
clauses <- mapM (goTree id) ress
|
||||
return $ instanceD [] (ConT ''RouteAttrs `AppT` typ)
|
||||
return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)
|
||||
[ FunD 'routeAttrs $ concat clauses
|
||||
]
|
||||
|
||||
|
||||
@ -322,7 +322,7 @@ main = hspec $ do
|
||||
it "hierarchy" $ do
|
||||
routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child")
|
||||
hierarchy
|
||||
describe "parseRouteTyoe" $ do
|
||||
describe "parseRouteType" $ do
|
||||
let success s t = it s $ parseTypeTree s @?= Just t
|
||||
failure s = it s $ parseTypeTree s @?= Nothing
|
||||
success "Int" $ TTTerm "Int"
|
||||
@ -334,6 +334,8 @@ 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"
|
||||
|
||||
@ -6,6 +6,7 @@ import YesodCoreTest.Exceptions
|
||||
import YesodCoreTest.Widget
|
||||
import YesodCoreTest.Media
|
||||
import YesodCoreTest.Links
|
||||
import YesodCoreTest.Header
|
||||
import YesodCoreTest.NoOverloadedStrings
|
||||
import YesodCoreTest.InternalRequest
|
||||
import YesodCoreTest.ErrorHandling
|
||||
@ -27,6 +28,7 @@ import Test.Hspec
|
||||
|
||||
specs :: Spec
|
||||
specs = do
|
||||
headerTest
|
||||
cleanPathTest
|
||||
exceptionsTest
|
||||
widgetTest
|
||||
|
||||
77
yesod-core/test/YesodCoreTest/Header.hs
Normal file
77
yesod-core/test/YesodCoreTest/Header.hs
Normal file
@ -0,0 +1,77 @@
|
||||
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes,
|
||||
TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}
|
||||
|
||||
module YesodCoreTest.Header
|
||||
( headerTest
|
||||
, Widget
|
||||
, resourcesApp
|
||||
) where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Types (decodePathSegments)
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import Test.Hspec
|
||||
import Yesod.Core
|
||||
|
||||
data App =
|
||||
App
|
||||
|
||||
mkYesod
|
||||
"App"
|
||||
[parseRoutes|
|
||||
/header1 Header1R GET
|
||||
/header2 Header2R GET
|
||||
/header3 Header3R GET
|
||||
|]
|
||||
|
||||
instance Yesod App
|
||||
|
||||
getHeader1R :: Handler RepPlain
|
||||
getHeader1R = do
|
||||
addHeader "hello" "world"
|
||||
return $ RepPlain $ toContent ("header test" :: Text)
|
||||
|
||||
getHeader2R :: Handler RepPlain
|
||||
getHeader2R = do
|
||||
addHeader "hello" "world"
|
||||
replaceOrAddHeader "hello" "sibi"
|
||||
return $ RepPlain $ toContent ("header test" :: Text)
|
||||
|
||||
getHeader3R :: Handler RepPlain
|
||||
getHeader3R = do
|
||||
addHeader "hello" "world"
|
||||
addHeader "michael" "snoyman"
|
||||
addHeader "yesod" "framework"
|
||||
replaceOrAddHeader "yesod" "book"
|
||||
return $ RepPlain $ toContent ("header test" :: Text)
|
||||
|
||||
runner :: Session () -> IO ()
|
||||
runner f = toWaiApp App >>= runSession f
|
||||
|
||||
addHeaderTest :: IO ()
|
||||
addHeaderTest =
|
||||
runner $ do
|
||||
res <- request defaultRequest {pathInfo = decodePathSegments "/header1"}
|
||||
assertHeader "hello" "world" res
|
||||
|
||||
multipleHeaderTest :: IO ()
|
||||
multipleHeaderTest =
|
||||
runner $ do
|
||||
res <- request defaultRequest {pathInfo = decodePathSegments "/header2"}
|
||||
assertHeader "hello" "sibi" res
|
||||
|
||||
header3Test :: IO ()
|
||||
header3Test = do
|
||||
runner $ do
|
||||
res <- request defaultRequest {pathInfo = decodePathSegments "/header3"}
|
||||
assertHeader "hello" "world" res
|
||||
assertHeader "michael" "snoyman" res
|
||||
assertHeader "yesod" "book" res
|
||||
|
||||
headerTest :: Spec
|
||||
headerTest =
|
||||
describe "Test.Header" $ do
|
||||
it "addHeader" addHeaderTest
|
||||
it "multiple header" multipleHeaderTest
|
||||
it "persist headers" header3Test
|
||||
@ -25,6 +25,7 @@ mkYesod "Y" [parseRoutes|
|
||||
/route-test-2/*Vector-String RT2 GET
|
||||
/route-test-3/*Vector-(Maybe-Int) RT3 GET
|
||||
/route-test-4/#(Foo-Int-Int) RT4 GET
|
||||
/route-test-4-spaces/#{Foo Int Int} RT4Spaces GET
|
||||
|]
|
||||
|
||||
data Vector a = Vector
|
||||
@ -64,6 +65,9 @@ getRT3 _ = return ()
|
||||
getRT4 :: Foo Int Int -> Handler ()
|
||||
getRT4 _ = return ()
|
||||
|
||||
getRT4Spaces :: Foo Int Int -> Handler ()
|
||||
getRT4Spaces _ = return ()
|
||||
|
||||
linksTest :: Spec
|
||||
linksTest = describe "Test.Links" $ do
|
||||
it "linkToHome" case_linkToHome
|
||||
|
||||
@ -6,7 +6,7 @@ module YesodCoreTest.Redirect
|
||||
) where
|
||||
|
||||
import YesodCoreTest.YesodTest
|
||||
import Yesod.Core.Handler (redirectWith, setEtag)
|
||||
import Yesod.Core.Handler (redirectWith, setEtag, setWeakEtag)
|
||||
import qualified Network.HTTP.Types as H
|
||||
|
||||
data Y = Y
|
||||
@ -17,6 +17,7 @@ mkYesod "Y" [parseRoutes|
|
||||
/r307 R307 GET
|
||||
/rregular RRegular GET
|
||||
/etag EtagR GET
|
||||
/weak-etag WeakEtagR GET
|
||||
|]
|
||||
instance Yesod Y where approot = ApprootStatic "http://test"
|
||||
app :: Session () -> IO ()
|
||||
@ -28,12 +29,13 @@ getRootR = return ()
|
||||
postRootR :: Handler ()
|
||||
postRootR = return ()
|
||||
|
||||
getR301, getR303, getR307, getRRegular, getEtagR :: Handler ()
|
||||
getR301, getR303, getR307, getRRegular, getEtagR, getWeakEtagR :: Handler ()
|
||||
getR301 = redirectWith H.status301 RootR
|
||||
getR303 = redirectWith H.status303 RootR
|
||||
getR307 = redirectWith H.status307 RootR
|
||||
getRRegular = redirect RootR
|
||||
getEtagR = setEtag "hello world"
|
||||
getWeakEtagR = setWeakEtag "hello world"
|
||||
|
||||
specs :: Spec
|
||||
specs = describe "Redirect" $ do
|
||||
@ -77,6 +79,8 @@ specs = describe "Redirect" $ do
|
||||
res <- request defaultRequest { pathInfo = ["etag"] }
|
||||
assertStatus 200 res
|
||||
assertHeader "etag" "\"hello world\"" res
|
||||
-- Note: this violates the RFC around ETag format, but is being left as is
|
||||
-- out of concerns that it might break existing users with misbehaving clients.
|
||||
it "single, unquoted if-none-match" $ app $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["etag"]
|
||||
@ -102,9 +106,27 @@ specs = describe "Redirect" $ do
|
||||
, requestHeaders = [("if-none-match", "\"foo\", \"hello world\"")]
|
||||
}
|
||||
assertStatus 304 res
|
||||
it "ignore weak" $ app $ do
|
||||
it "ignore weak when provided normal etag" $ app $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["etag"]
|
||||
, requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")]
|
||||
}
|
||||
assertStatus 200 res
|
||||
it "weak etag" $ app $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["weak-etag"]
|
||||
, requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")]
|
||||
}
|
||||
assertStatus 304 res
|
||||
it "different if-none-match for weak etag" $ app $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["weak-etag"]
|
||||
, requestHeaders = [("if-none-match", "W/\"foo\"")]
|
||||
}
|
||||
assertStatus 200 res
|
||||
it "ignore strong when expecting weak" $ app $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["weak-etag"]
|
||||
, requestHeaders = [("if-none-match", "\"hello world\", W/\"foo\"")]
|
||||
}
|
||||
assertStatus 200 res
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-core
|
||||
version: 1.4.31
|
||||
version: 1.4.37.2
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -21,7 +21,7 @@ extra-source-files:
|
||||
README.md
|
||||
|
||||
library
|
||||
build-depends: base >= 4.6 && < 5
|
||||
build-depends: base >= 4.7 && < 5
|
||||
, time >= 1.1.4
|
||||
, wai >= 3.0
|
||||
, wai-extra >= 3.0.7
|
||||
@ -150,6 +150,7 @@ test-suite tests
|
||||
YesodCoreTest.Auth
|
||||
YesodCoreTest.Cache
|
||||
YesodCoreTest.CleanPath
|
||||
YesodCoreTest.Header
|
||||
YesodCoreTest.Csrf
|
||||
YesodCoreTest.ErrorHandling
|
||||
YesodCoreTest.Exceptions
|
||||
|
||||
@ -1 +1,3 @@
|
||||
No changes logged yet
|
||||
## 1.4.1
|
||||
|
||||
* Fix warnings
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-eventsource
|
||||
version: 1.4.0.1
|
||||
version: 1.4.1
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Felipe Lessa <felipe.lessa@gmail.com>
|
||||
|
||||
@ -1,3 +1,30 @@
|
||||
## 1.4.16
|
||||
|
||||
* Korean translation
|
||||
|
||||
## 1.4.15
|
||||
|
||||
* Added `Alternative` instance to `FormResult` to simplify handling pages with multiple forms.
|
||||
|
||||
## 1.4.14
|
||||
|
||||
* Added `WForm` to reduce the verbosity using monadic forms.
|
||||
* Added `wreq` and `wopt` correspondent functions for `WForm`.
|
||||
|
||||
## 1.4.13
|
||||
|
||||
* Fixed `textareaField` `writeHtmlEscapedChar` trim "\r"
|
||||
|
||||
## 1.4.12
|
||||
|
||||
* Password field does not remember its previous value
|
||||
|
||||
## 1.4.11
|
||||
|
||||
* Fix warnings
|
||||
* Fixed spelling errors and wording for `Yesod.Form.Functions.convertField`'s
|
||||
documentation
|
||||
|
||||
## 1.4.10
|
||||
|
||||
* Fixed `identifyForm` to properly return `FormMissing` for empty forms. [#1072](https://github.com/yesodweb/yesod/issues/1072)
|
||||
|
||||
@ -76,7 +76,7 @@ import Database.Persist.Sql (PersistField, PersistFieldSql (..))
|
||||
#if MIN_VERSION_persistent(2,5,0)
|
||||
import Database.Persist (Entity (..), SqlType (SqlString), PersistRecordBackend, PersistQueryRead)
|
||||
#else
|
||||
import Database.Persist (Entity (..), SqlType (SqlString))
|
||||
import Database.Persist (Entity (..), SqlType (SqlString), PersistEntity, PersistQuery, PersistEntityBackend)
|
||||
#endif
|
||||
import Text.HTML.SanitizeXSS (sanitizeBalance)
|
||||
import Control.Monad (when, unless)
|
||||
@ -106,6 +106,10 @@ import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput,
|
||||
|
||||
import Yesod.Persist.Core
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Data.Monoid
|
||||
#endif
|
||||
|
||||
defaultFormMessage :: FormMessage -> Text
|
||||
defaultFormMessage = englishFormMessage
|
||||
|
||||
@ -226,6 +230,7 @@ instance ToHtml Textarea where
|
||||
. unTextarea
|
||||
where
|
||||
-- Taken from blaze-builder and modified with newline handling.
|
||||
writeHtmlEscapedChar '\r' = mempty
|
||||
writeHtmlEscapedChar '\n' = writeByteString "<br>"
|
||||
writeHtmlEscapedChar c = B.writeHtmlEscapedChar c
|
||||
|
||||
@ -267,9 +272,9 @@ $newline never
|
||||
passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
|
||||
passwordField = Field
|
||||
{ fieldParse = parseHelper $ Right
|
||||
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
||||
, fieldView = \theId name attrs _ isReq -> toWidget [hamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}">
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="">
|
||||
|]
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
@ -13,7 +13,12 @@ module Yesod.Form.Functions
|
||||
-- * Applicative/Monadic conversion
|
||||
, formToAForm
|
||||
, aFormToForm
|
||||
, mFormToWForm
|
||||
, wFormToAForm
|
||||
, wFormToMForm
|
||||
-- * Fields to Forms
|
||||
, wreq
|
||||
, wopt
|
||||
, mreq
|
||||
, mopt
|
||||
, areq
|
||||
@ -51,8 +56,9 @@ module Yesod.Form.Functions
|
||||
import Yesod.Form.Types
|
||||
import Data.Text (Text, pack)
|
||||
import Control.Arrow (second)
|
||||
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local)
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST)
|
||||
import Control.Monad.Trans.Writer (runWriterT, writer)
|
||||
import Control.Monad (liftM, join)
|
||||
import Data.Byteable (constEqBytes)
|
||||
import Text.Blaze (Markup, toMarkup)
|
||||
@ -105,6 +111,58 @@ askFiles = do
|
||||
(x, _, _) <- ask
|
||||
return $ liftM snd x
|
||||
|
||||
-- | Converts a form field into monadic form 'WForm'. This field requires a
|
||||
-- value and will return 'FormFailure' if left empty.
|
||||
--
|
||||
-- @since 1.4.14
|
||||
wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -- ^ form field
|
||||
-> FieldSettings site -- ^ settings for this field
|
||||
-> Maybe a -- ^ optional default value
|
||||
-> WForm m (FormResult a)
|
||||
wreq f fs = mFormToWForm . mreq f fs
|
||||
|
||||
-- | Converts a form field into monadic form 'WForm'. This field is optional,
|
||||
-- i.e. if filled in, it returns 'Just a', if left empty, it returns
|
||||
-- 'Nothing'. Arguments are the same as for 'wreq' (apart from type of default
|
||||
-- value).
|
||||
--
|
||||
-- @since 1.4.14
|
||||
wopt :: (MonadHandler m, HandlerSite m ~ site)
|
||||
=> Field m a -- ^ form field
|
||||
-> FieldSettings site -- ^ settings for this field
|
||||
-> Maybe (Maybe a) -- ^ optional default value
|
||||
-> WForm m (FormResult (Maybe a))
|
||||
wopt f fs = mFormToWForm . mopt f fs
|
||||
|
||||
-- | Converts a monadic form 'WForm' into an applicative form 'AForm'.
|
||||
--
|
||||
-- @since 1.4.14
|
||||
wFormToAForm :: MonadHandler m
|
||||
=> WForm m (FormResult a) -- ^ input form
|
||||
-> AForm m a -- ^ output form
|
||||
wFormToAForm = formToAForm . wFormToMForm
|
||||
|
||||
-- | Converts a monadic form 'WForm' into another monadic form 'MForm'.
|
||||
--
|
||||
-- @since 1.4.14
|
||||
wFormToMForm :: (MonadHandler m, HandlerSite m ~ site)
|
||||
=> WForm m a -- ^ input form
|
||||
-> MForm m (a, [FieldView site]) -- ^ output form
|
||||
wFormToMForm = mapRWST (fmap group . runWriterT)
|
||||
where
|
||||
group ((a, ints, enctype), views) = ((a, views), ints, enctype)
|
||||
|
||||
-- | Converts a monadic form 'MForm' into another monadic form 'WForm'.
|
||||
--
|
||||
-- @since 1.4.14
|
||||
mFormToWForm :: (MonadHandler m, HandlerSite m ~ site)
|
||||
=> MForm m (a, FieldView site) -- ^ input form
|
||||
-> WForm m a -- ^ output form
|
||||
mFormToWForm = mapRWST $ \f -> do
|
||||
((a, view), ints, enctype) <- lift f
|
||||
writer ((a, ints, enctype), [view])
|
||||
|
||||
-- | Converts a form field into monadic form. This field requires a value
|
||||
-- and will return 'FormFailure' if left empty.
|
||||
mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
@ -534,8 +592,8 @@ parseHelperGen f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $
|
||||
|
||||
-- | Since a 'Field' cannot be a 'Functor', it is not obvious how to "reuse" a Field
|
||||
-- on a @newtype@ or otherwise equivalent type. This function allows you to convert
|
||||
-- a @Field m a@ to a @Field m b@ assuming you provide a bidireccional
|
||||
-- convertion among the two, through the first two functions.
|
||||
-- a @Field m a@ to a @Field m b@ assuming you provide a bidirectional
|
||||
-- conversion between the two, through the first two functions.
|
||||
--
|
||||
-- A simple example:
|
||||
--
|
||||
|
||||
26
yesod-form/Yesod/Form/I18n/Chinese.hs
Normal file
26
yesod-form/Yesod/Form/I18n/Chinese.hs
Normal file
@ -0,0 +1,26 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Yesod.Form.I18n.Chinese where
|
||||
|
||||
import Yesod.Form.Types (FormMessage (..))
|
||||
import Data.Monoid (mappend)
|
||||
import Data.Text (Text)
|
||||
|
||||
chineseFormMessage :: FormMessage -> Text
|
||||
chineseFormMessage (MsgInvalidInteger t) = "无效的整数: " `Data.Monoid.mappend` t
|
||||
chineseFormMessage (MsgInvalidNumber t) = "无效的数字: " `mappend` t
|
||||
chineseFormMessage (MsgInvalidEntry t) = "无效的条目: " `mappend` t
|
||||
chineseFormMessage MsgInvalidTimeFormat = "无效的时间, 必须符合HH:MM[:SS]格式"
|
||||
chineseFormMessage MsgInvalidDay = "无效的日期, 必须符合YYYY-MM-DD格式"
|
||||
chineseFormMessage (MsgInvalidUrl t) = "无效的链接: " `mappend` t
|
||||
chineseFormMessage (MsgInvalidEmail t) = "无效的邮箱地址: " `mappend` t
|
||||
chineseFormMessage (MsgInvalidHour t) = "无效的小时: " `mappend` t
|
||||
chineseFormMessage (MsgInvalidMinute t) = "无效的分钟: " `mappend` t
|
||||
chineseFormMessage (MsgInvalidSecond t) = "无效的秒: " `mappend` t
|
||||
chineseFormMessage MsgCsrfWarning = "为了防备跨站请求伪造, 请确认表格提交."
|
||||
chineseFormMessage MsgValueRequired = "此项必填"
|
||||
chineseFormMessage (MsgInputNotFound t) = "输入找不到: " `mappend` t
|
||||
chineseFormMessage MsgSelectNone = "<空>"
|
||||
chineseFormMessage (MsgInvalidBool t) = "无效的逻辑值: " `mappend` t
|
||||
chineseFormMessage MsgBoolYes = "是"
|
||||
chineseFormMessage MsgBoolNo = "否"
|
||||
chineseFormMessage MsgDelete = "删除?"
|
||||
26
yesod-form/Yesod/Form/I18n/Korean.hs
Normal file
26
yesod-form/Yesod/Form/I18n/Korean.hs
Normal file
@ -0,0 +1,26 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Yesod.Form.I18n.Korean where
|
||||
|
||||
import Yesod.Form.Types (FormMessage (..))
|
||||
import Data.Monoid (mappend)
|
||||
import Data.Text (Text)
|
||||
|
||||
koreanFormMessage :: FormMessage -> Text
|
||||
koreanFormMessage (MsgInvalidInteger t) = "잘못된 정수입니다: " `Data.Monoid.mappend` t
|
||||
koreanFormMessage (MsgInvalidNumber t) = "잘못된 숫자입니다: " `mappend` t
|
||||
koreanFormMessage (MsgInvalidEntry t) = "잘못된 입력입니다: " `mappend` t
|
||||
koreanFormMessage MsgInvalidTimeFormat = "잘못된 시간입니다. HH:MM[:SS] 형태로 입력하세요"
|
||||
koreanFormMessage MsgInvalidDay = "잘못된 날짜입니다. YYYY-MM-DD 형태로 입력하세요"
|
||||
koreanFormMessage (MsgInvalidUrl t) = "잘못된 URL입니다: " `mappend` t
|
||||
koreanFormMessage (MsgInvalidEmail t) = "잘못된 이메일 주소입니다: " `mappend` t
|
||||
koreanFormMessage (MsgInvalidHour t) = "잘못된 시간입니다: " `mappend` t
|
||||
koreanFormMessage (MsgInvalidMinute t) = "잘못된 분입니다: " `mappend` t
|
||||
koreanFormMessage (MsgInvalidSecond t) = "잘못된 초입니다: " `mappend` t
|
||||
koreanFormMessage MsgCsrfWarning = "CSRF공격을 방지하기 위해 양식의 입력을 확인하세요."
|
||||
koreanFormMessage MsgValueRequired = "값은 필수입니다"
|
||||
koreanFormMessage (MsgInputNotFound t) = "입력을 찾을 수 없습니다: " `mappend` t
|
||||
koreanFormMessage MsgSelectNone = "<없음>"
|
||||
koreanFormMessage (MsgInvalidBool t) = "잘못된 불(boolean)입니다: " `mappend` t
|
||||
koreanFormMessage MsgBoolYes = "예"
|
||||
koreanFormMessage MsgBoolNo = "아니오"
|
||||
koreanFormMessage MsgDelete = "삭제하시겠습니까?"
|
||||
@ -25,7 +25,7 @@ import Control.Arrow ((***))
|
||||
type DText = [Text] -> [Text]
|
||||
|
||||
-- | Type for a form which parses a value of type @a@ with the base monad @m@
|
||||
-- (usually your @Handler@). Can can compose this using its @Applicative@ instance.
|
||||
-- (usually your @Handler@). Can compose this using its @Applicative@ instance.
|
||||
newtype FormInput m a = FormInput { unFormInput :: HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a) }
|
||||
instance Monad m => Functor (FormInput m) where
|
||||
fmap a (FormInput f) = FormInput $ \c d e e' -> liftM (either Left (Right . a)) $ f c d e e'
|
||||
|
||||
@ -12,6 +12,7 @@ module Yesod.Form.Types
|
||||
, FileEnv
|
||||
, Ints (..)
|
||||
-- * Form
|
||||
, WForm
|
||||
, MForm
|
||||
, AForm (..)
|
||||
-- * Build forms
|
||||
@ -22,13 +23,14 @@ module Yesod.Form.Types
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
import Control.Monad.Trans.Writer (WriterT)
|
||||
import Data.Text (Text)
|
||||
import Data.Monoid (Monoid (..))
|
||||
import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue))
|
||||
#define Html Markup
|
||||
#define ToHtml ToMarkup
|
||||
#define toHtml toMarkup
|
||||
import Control.Applicative ((<$>), Applicative (..))
|
||||
import Control.Applicative ((<$>), Alternative (..), Applicative (..))
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.Trans.Class
|
||||
import Data.String (IsString (..))
|
||||
@ -43,6 +45,8 @@ import Data.Foldable
|
||||
--
|
||||
-- The 'Applicative' instance will concatenate the failure messages in two
|
||||
-- 'FormResult's.
|
||||
-- The 'Alternative' instance will choose 'FormFailure' before 'FormSuccess',
|
||||
-- and 'FormMissing' last of all.
|
||||
data FormResult a = FormMissing
|
||||
| FormFailure [Text]
|
||||
| FormSuccess a
|
||||
@ -78,6 +82,16 @@ instance Data.Traversable.Traversable FormResult where
|
||||
FormFailure errs -> pure (FormFailure errs)
|
||||
FormMissing -> pure FormMissing
|
||||
|
||||
-- | @since 1.4.15
|
||||
instance Alternative FormResult where
|
||||
empty = FormMissing
|
||||
|
||||
FormFailure e <|> _ = FormFailure e
|
||||
_ <|> FormFailure e = FormFailure e
|
||||
FormSuccess s <|> FormSuccess _ = FormSuccess s
|
||||
FormMissing <|> result = result
|
||||
result <|> FormMissing = result
|
||||
|
||||
-- | The encoding type required by a form. The 'ToHtml' instance produces values
|
||||
-- that can be inserted directly into HTML.
|
||||
data Enctype = UrlEncoded | Multipart
|
||||
@ -102,6 +116,29 @@ instance Show Ints where
|
||||
type Env = Map.Map Text [Text]
|
||||
type FileEnv = Map.Map Text [FileInfo]
|
||||
|
||||
-- | 'MForm' variant stacking a 'WriterT'. The following code example using a
|
||||
-- monadic form 'MForm':
|
||||
--
|
||||
-- > formToAForm $ do
|
||||
-- > (field1F, field1V) <- mreq textField MsgField1 Nothing
|
||||
-- > (field2F, field2V) <- mreq (checkWith field1F textField) MsgField2 Nothing
|
||||
-- > (field3F, field3V) <- mreq (checkWith field1F textField) MsgField3 Nothing
|
||||
-- > return
|
||||
-- > ( MyForm <$> field1F <*> field2F <*> field3F
|
||||
-- > , [field1V, field2V, field3V]
|
||||
-- > )
|
||||
--
|
||||
-- Could be rewritten as follows using 'WForm':
|
||||
--
|
||||
-- > wFormToAForm $ do
|
||||
-- > field1F <- wreq textField MsgField1 Nothing
|
||||
-- > field2F <- wreq (checkWith field1F textField) MsgField2 Nothing
|
||||
-- > field3F <- wreq (checkWith field1F textField) MsgField3 Nothing
|
||||
-- > return $ MyForm <$> field1F <*> field2F <*> field3F
|
||||
--
|
||||
-- @since 1.4.14
|
||||
type WForm m a = MForm (WriterT [FieldView (HandlerSite m)] m) a
|
||||
|
||||
type MForm m a = RWST
|
||||
(Maybe (Env, FileEnv), HandlerSite m, [Lang])
|
||||
Enctype
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-form
|
||||
version: 1.4.10
|
||||
version: 1.4.16
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -68,6 +68,8 @@ library
|
||||
Yesod.Form.I18n.Russian
|
||||
Yesod.Form.I18n.Dutch
|
||||
Yesod.Form.I18n.Spanish
|
||||
Yesod.Form.I18n.Chinese
|
||||
Yesod.Form.I18n.Korean
|
||||
-- FIXME Yesod.Helpers.Crud
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
@ -1,3 +1,11 @@
|
||||
## 1.4.3
|
||||
|
||||
* Fix overly powerful constraints on get404 and getBy404.
|
||||
|
||||
## 1.4.2
|
||||
|
||||
* Fix warnings
|
||||
|
||||
## 1.4.1.1
|
||||
|
||||
* Fix build failure with older persistent versions [#1324](https://github.com/yesodweb/yesod/issues/1324)
|
||||
|
||||
@ -134,7 +134,7 @@ respondSourceDB ctype = respondSource ctype . runDBSource
|
||||
|
||||
-- | Get the given entity by ID, or return a 404 not found if it doesn't exist.
|
||||
#if MIN_VERSION_persistent(2,5,0)
|
||||
get404 :: (MonadIO m, PersistStore backend, PersistRecordBackend val backend)
|
||||
get404 :: (MonadIO m, PersistStoreRead backend, PersistRecordBackend val backend)
|
||||
=> Key val
|
||||
-> ReaderT backend m val
|
||||
#else
|
||||
@ -151,7 +151,7 @@ get404 key = do
|
||||
-- | Get the given entity by unique key, or return a 404 not found if it doesn't
|
||||
-- exist.
|
||||
#if MIN_VERSION_persistent(2,5,0)
|
||||
getBy404 :: (PersistUnique backend, PersistRecordBackend val backend, MonadIO m)
|
||||
getBy404 :: (PersistUniqueRead backend, PersistRecordBackend val backend, MonadIO m)
|
||||
=> Unique val
|
||||
-> ReaderT backend m (Entity val)
|
||||
#else
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-persistent
|
||||
version: 1.4.1.1
|
||||
version: 1.4.3
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -16,8 +16,8 @@ extra-source-files: README.md ChangeLog.md
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 1.4.0 && < 1.5
|
||||
, persistent >= 2.1 && < 2.7
|
||||
, persistent-template >= 2.1 && < 2.7
|
||||
, persistent >= 2.1 && < 2.8
|
||||
, persistent-template >= 2.1 && < 2.8
|
||||
, transformers >= 0.2.2
|
||||
, blaze-builder
|
||||
, conduit
|
||||
|
||||
@ -1,3 +1,17 @@
|
||||
## 1.5.3.1
|
||||
|
||||
* Switch to cryptonite
|
||||
|
||||
## 1.5.3
|
||||
|
||||
* Add `staticFilesMap` function
|
||||
* Add `staticFilesMergeMap` function
|
||||
|
||||
## 1.5.2
|
||||
|
||||
* Fix test case for CRLF line endings
|
||||
* Fix warnings
|
||||
|
||||
## 1.5.1.1
|
||||
|
||||
* Fix test suite compilation
|
||||
|
||||
@ -51,6 +51,8 @@ module Yesod.Static
|
||||
-- * Template Haskell helpers
|
||||
, staticFiles
|
||||
, staticFilesList
|
||||
, staticFilesMap
|
||||
, staticFilesMergeMap
|
||||
, publicFiles
|
||||
-- * Hashing
|
||||
, base64md5
|
||||
@ -62,6 +64,7 @@ module Yesod.Static
|
||||
) where
|
||||
|
||||
import System.Directory
|
||||
import qualified System.FilePath as FP
|
||||
import Control.Monad
|
||||
import Data.FileEmbed (embedDir)
|
||||
|
||||
@ -78,7 +81,7 @@ import Crypto.Hash (MD5, Digest)
|
||||
import Control.Monad.Catch (MonadThrow)
|
||||
import Control.Monad.Trans.State
|
||||
|
||||
import qualified Data.Byteable as Byteable
|
||||
import qualified Data.ByteArray as ByteArray
|
||||
import qualified Data.ByteString.Base64
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
@ -246,7 +249,7 @@ staticFiles dir = mkStaticFiles dir
|
||||
-- files @\"static\/js\/jquery.js\"@ and
|
||||
-- @\"static\/css\/normalize.css\"@, you would use:
|
||||
--
|
||||
-- > staticFilesList \"static\" [\"js\/jquery.js\", \"css\/normalize.css\"]
|
||||
-- > staticFilesList "static" ["js/jquery.js", "css/normalize.css"]
|
||||
--
|
||||
-- This can be useful when you have a very large number of static
|
||||
-- files, but only need to refer to a few of them from Haskell.
|
||||
@ -273,6 +276,53 @@ staticFilesList dir fs =
|
||||
publicFiles :: FilePath -> Q [Dec]
|
||||
publicFiles dir = mkStaticFiles' dir False
|
||||
|
||||
-- | Similar to 'staticFilesList', but takes a mapping of
|
||||
-- unmunged names to fingerprinted file names.
|
||||
--
|
||||
-- @since 1.5.3
|
||||
staticFilesMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec]
|
||||
staticFilesMap fp m = mkStaticFilesList' fp (map splitBoth mapList) True
|
||||
where
|
||||
splitBoth (k, v) = (split k, split v)
|
||||
mapList = M.toList m
|
||||
split :: FilePath -> [String]
|
||||
split [] = []
|
||||
split x =
|
||||
let (a, b) = break (== '/') x
|
||||
in a : split (drop 1 b)
|
||||
|
||||
-- | Similar to 'staticFilesMergeMap', but also generates identifiers
|
||||
-- for all files in the specified directory that don't have a
|
||||
-- fingerprinted version.
|
||||
--
|
||||
-- @since 1.5.3
|
||||
staticFilesMergeMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec]
|
||||
staticFilesMergeMap fp m = do
|
||||
fs <- qRunIO $ getFileListPieces fp
|
||||
let filesList = map FP.joinPath fs
|
||||
mergedMapList = M.toList $ foldl' (checkedInsert invertedMap) m filesList
|
||||
mkStaticFilesList' fp (map splitBoth mergedMapList) True
|
||||
where
|
||||
splitBoth (k, v) = (split k, split v)
|
||||
swap (x, y) = (y, x)
|
||||
mapList = M.toList m
|
||||
invertedMap = M.fromList $ map swap mapList
|
||||
split :: FilePath -> [String]
|
||||
split [] = []
|
||||
split x =
|
||||
let (a, b) = break (== '/') x
|
||||
in a : split (drop 1 b)
|
||||
-- We want to keep mappings for all files that are pre-fingerprinted,
|
||||
-- so this function checks against all of the existing fingerprinted files and
|
||||
-- only inserts a new mapping if it's not a fingerprinted file.
|
||||
checkedInsert
|
||||
:: M.Map FilePath FilePath -- inverted dictionary
|
||||
-> M.Map FilePath FilePath -- accumulating state
|
||||
-> FilePath
|
||||
-> M.Map FilePath FilePath
|
||||
checkedInsert iDict st p = if M.member p iDict
|
||||
then st
|
||||
else M.insert p p st
|
||||
|
||||
mkHashMap :: FilePath -> IO (M.Map FilePath S8.ByteString)
|
||||
mkHashMap dir = do
|
||||
@ -330,7 +380,16 @@ mkStaticFilesList
|
||||
-> [[String]] -- ^ list of files to create identifiers for
|
||||
-> Bool -- ^ append checksum query parameter
|
||||
-> Q [Dec]
|
||||
mkStaticFilesList fp fs makeHash = do
|
||||
mkStaticFilesList fp fs makeHash = mkStaticFilesList' fp (zip fs fs) makeHash
|
||||
|
||||
mkStaticFilesList'
|
||||
:: FilePath -- ^ static directory
|
||||
-> [([String], [String])] -- ^ list of files to create identifiers for, where
|
||||
-- the first argument of the tuple is the identifier
|
||||
-- alias and the second is the actual file name
|
||||
-> Bool -- ^ append checksum query parameter
|
||||
-> Q [Dec]
|
||||
mkStaticFilesList' fp fs makeHash = do
|
||||
concat `fmap` mapM mkRoute fs
|
||||
where
|
||||
replace' c
|
||||
@ -338,8 +397,8 @@ mkStaticFilesList fp fs makeHash = do
|
||||
| 'a' <= c && c <= 'z' = c
|
||||
| '0' <= c && c <= '9' = c
|
||||
| otherwise = '_'
|
||||
mkRoute f = do
|
||||
let name' = intercalate "_" $ map (map replace') f
|
||||
mkRoute (alias, f) = do
|
||||
let name' = intercalate "_" $ map (map replace') alias
|
||||
routeName = mkName $
|
||||
case () of
|
||||
()
|
||||
@ -361,7 +420,7 @@ mkStaticFilesList fp fs makeHash = do
|
||||
|
||||
base64md5File :: FilePath -> IO String
|
||||
base64md5File = fmap (base64 . encode) . hashFile
|
||||
where encode d = Byteable.toBytes (d :: Digest MD5)
|
||||
where encode d = ByteArray.convert (d :: Digest MD5)
|
||||
|
||||
base64md5 :: L.ByteString -> String
|
||||
base64md5 lbs =
|
||||
@ -369,7 +428,7 @@ base64md5 lbs =
|
||||
$ runIdentity
|
||||
$ sourceList (L.toChunks lbs) $$ sinkHash
|
||||
where
|
||||
encode d = Byteable.toBytes (d :: Digest MD5)
|
||||
encode d = ByteArray.convert (d :: Digest MD5)
|
||||
|
||||
base64 :: S.ByteString -> String
|
||||
base64 = map tr
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-static
|
||||
version: 1.5.1.1
|
||||
version: 1.5.3.1
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -44,8 +44,9 @@ library
|
||||
, unix-compat >= 0.2
|
||||
, conduit >= 0.5
|
||||
, conduit-extra
|
||||
, cryptohash-conduit >= 0.1
|
||||
, cryptohash >= 0.11
|
||||
, cryptonite-conduit >= 0.1
|
||||
, cryptonite >= 0.11
|
||||
, memory
|
||||
, data-default
|
||||
, mime-types >= 0.1
|
||||
, hjsmin
|
||||
@ -112,8 +113,9 @@ test-suite tests
|
||||
, http-types
|
||||
, unix-compat
|
||||
, conduit
|
||||
, cryptohash-conduit
|
||||
, cryptohash
|
||||
, cryptonite-conduit
|
||||
, cryptonite
|
||||
, memory
|
||||
, data-default
|
||||
, mime-types
|
||||
, hjsmin
|
||||
|
||||
@ -1,3 +1,21 @@
|
||||
## 1.5.8
|
||||
* Added implicit parameter HasCallStack to assertions.
|
||||
[#1421](https://github.com/yesodweb/yesod/pull/1421)
|
||||
|
||||
## 1.5.7
|
||||
|
||||
* Add clickOn.
|
||||
[#1408](https://github.com/yesodweb/yesod/pull/1408)
|
||||
|
||||
## 1.5.6
|
||||
|
||||
* Add assertNotEq.
|
||||
[#1375](https://github.com/yesodweb/yesod/pull/1375)
|
||||
|
||||
## 1.5.5
|
||||
|
||||
* Fix warnings
|
||||
|
||||
## 1.5.4.1
|
||||
|
||||
* Compilation fix for GHC 7.8
|
||||
|
||||
@ -4,6 +4,8 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
|
||||
{-|
|
||||
Yesod.Test is a pragmatic framework for testing web applications built
|
||||
@ -62,6 +64,7 @@ module Yesod.Test
|
||||
, setRequestBody
|
||||
, RequestBuilder
|
||||
, setUrl
|
||||
, clickOn
|
||||
|
||||
-- *** Adding fields by label
|
||||
-- | Yesod can auto generate field names, so you are never sure what
|
||||
@ -86,6 +89,7 @@ module Yesod.Test
|
||||
|
||||
-- * Assertions
|
||||
, assertEqual
|
||||
, assertNotEq
|
||||
, assertEqualNoShow
|
||||
, assertEq
|
||||
|
||||
@ -148,6 +152,16 @@ import Data.Time.Clock (getCurrentTime)
|
||||
import Control.Applicative ((<$>))
|
||||
import Text.Show.Pretty (ppShow)
|
||||
import Data.Monoid (mempty)
|
||||
#if MIN_VERSION_base(4,9,0)
|
||||
import GHC.Stack (HasCallStack)
|
||||
#elif MIN_VERSION_base(4,8,1)
|
||||
import GHC.Stack (CallStack)
|
||||
type HasCallStack = (?callStack :: CallStack)
|
||||
#else
|
||||
import GHC.Exts (Constraint)
|
||||
type HasCallStack = (() :: Constraint)
|
||||
#endif
|
||||
|
||||
|
||||
-- | The state used in a single test case defined using 'yit'
|
||||
--
|
||||
@ -325,28 +339,39 @@ htmlQuery = htmlQuery' yedResponse []
|
||||
|
||||
-- | Asserts that the two given values are equal.
|
||||
--
|
||||
-- In case they are not equal, error mesasge includes the two values.
|
||||
-- In case they are not equal, error message includes the two values.
|
||||
--
|
||||
-- @since 1.5.2
|
||||
assertEq :: (Eq a, Show a) => String -> a -> a -> YesodExample site ()
|
||||
assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
|
||||
assertEq m a b =
|
||||
liftIO $ HUnit.assertBool msg (a == b)
|
||||
where msg = "Assertion: " ++ m ++ "\n" ++
|
||||
"First argument: " ++ ppShow a ++ "\n" ++
|
||||
"Second argument: " ++ ppShow b ++ "\n"
|
||||
|
||||
-- | Asserts that the two given values are not equal.
|
||||
--
|
||||
-- In case they are equal, error mesasge includes the values.
|
||||
--
|
||||
-- @since 1.5.6
|
||||
assertNotEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
|
||||
assertNotEq m a b =
|
||||
liftIO $ HUnit.assertBool msg (a /= b)
|
||||
where msg = "Assertion: " ++ m ++ "\n" ++
|
||||
"Both arguments: " ++ ppShow a ++ "\n"
|
||||
|
||||
{-# DEPRECATED assertEqual "Use assertEq instead" #-}
|
||||
assertEqual :: (Eq a) => String -> a -> a -> YesodExample site ()
|
||||
assertEqual :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site ()
|
||||
assertEqual = assertEqualNoShow
|
||||
|
||||
-- | Asserts that the two given values are equal.
|
||||
--
|
||||
-- @since 1.5.2
|
||||
assertEqualNoShow :: (Eq a) => String -> a -> a -> YesodExample site ()
|
||||
assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site ()
|
||||
assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b)
|
||||
|
||||
-- | Assert the last response status is as expected.
|
||||
statusIs :: Int -> YesodExample site ()
|
||||
statusIs :: HasCallStack => Int -> YesodExample site ()
|
||||
statusIs number = withResponse $ \ SResponse { simpleStatus = s } ->
|
||||
liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat
|
||||
[ "Expected status was ", show number
|
||||
@ -354,7 +379,7 @@ statusIs number = withResponse $ \ SResponse { simpleStatus = s } ->
|
||||
]
|
||||
|
||||
-- | Assert the given header key/value pair was returned.
|
||||
assertHeader :: CI BS8.ByteString -> BS8.ByteString -> YesodExample site ()
|
||||
assertHeader :: HasCallStack => CI BS8.ByteString -> BS8.ByteString -> YesodExample site ()
|
||||
assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->
|
||||
case lookup header h of
|
||||
Nothing -> failure $ T.pack $ concat
|
||||
@ -374,7 +399,7 @@ assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->
|
||||
]
|
||||
|
||||
-- | Assert the given header was not included in the response.
|
||||
assertNoHeader :: CI BS8.ByteString -> YesodExample site ()
|
||||
assertNoHeader :: HasCallStack => CI BS8.ByteString -> YesodExample site ()
|
||||
assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->
|
||||
case lookup header h of
|
||||
Nothing -> return ()
|
||||
@ -387,14 +412,14 @@ assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->
|
||||
|
||||
-- | Assert the last response is exactly equal to the given text. This is
|
||||
-- useful for testing API responses.
|
||||
bodyEquals :: String -> YesodExample site ()
|
||||
bodyEquals :: HasCallStack => String -> YesodExample site ()
|
||||
bodyEquals text = withResponse $ \ res ->
|
||||
liftIO $ HUnit.assertBool ("Expected body to equal " ++ text) $
|
||||
(simpleBody res) == encodeUtf8 (TL.pack text)
|
||||
|
||||
-- | Assert the last response has the given text. The check is performed using the response
|
||||
-- body in full text form.
|
||||
bodyContains :: String -> YesodExample site ()
|
||||
bodyContains :: HasCallStack => String -> YesodExample site ()
|
||||
bodyContains text = withResponse $ \ res ->
|
||||
liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $
|
||||
(simpleBody res) `contains` text
|
||||
@ -402,7 +427,7 @@ bodyContains text = withResponse $ \ res ->
|
||||
-- | Assert the last response doesn't have the given text. The check is performed using the response
|
||||
-- body in full text form.
|
||||
-- @since 1.5.3
|
||||
bodyNotContains :: String -> YesodExample site ()
|
||||
bodyNotContains :: HasCallStack => String -> YesodExample site ()
|
||||
bodyNotContains text = withResponse $ \ res ->
|
||||
liftIO $ HUnit.assertBool ("Expected body not to contain " ++ text) $
|
||||
not $ contains (simpleBody res) text
|
||||
@ -412,7 +437,7 @@ contains a b = DL.isInfixOf b (TL.unpack $ decodeUtf8 a)
|
||||
|
||||
-- | Queries the HTML using a CSS selector, and all matched elements must contain
|
||||
-- the given string.
|
||||
htmlAllContain :: Query -> String -> YesodExample site ()
|
||||
htmlAllContain :: HasCallStack => Query -> String -> YesodExample site ()
|
||||
htmlAllContain query search = do
|
||||
matches <- htmlQuery query
|
||||
case matches of
|
||||
@ -424,7 +449,7 @@ htmlAllContain query search = do
|
||||
-- element contains the given string.
|
||||
--
|
||||
-- Since 0.3.5
|
||||
htmlAnyContain :: Query -> String -> YesodExample site ()
|
||||
htmlAnyContain :: HasCallStack => Query -> String -> YesodExample site ()
|
||||
htmlAnyContain query search = do
|
||||
matches <- htmlQuery query
|
||||
case matches of
|
||||
@ -437,7 +462,7 @@ htmlAnyContain query search = do
|
||||
-- inverse of htmlAnyContains).
|
||||
--
|
||||
-- Since 1.2.2
|
||||
htmlNoneContain :: Query -> String -> YesodExample site ()
|
||||
htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site ()
|
||||
htmlNoneContain query search = do
|
||||
matches <- htmlQuery query
|
||||
case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of
|
||||
@ -447,7 +472,7 @@ htmlNoneContain query search = do
|
||||
|
||||
-- | Performs a CSS query on the last response and asserts the matched elements
|
||||
-- are as many as expected.
|
||||
htmlCount :: Query -> Int -> YesodExample site ()
|
||||
htmlCount :: HasCallStack => Query -> Int -> YesodExample site ()
|
||||
htmlCount query count = do
|
||||
matches <- fmap DL.length $ htmlQuery query
|
||||
liftIO $ flip HUnit.assertBool (matches == count)
|
||||
@ -818,6 +843,25 @@ setUrl url' = do
|
||||
, rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery)
|
||||
}
|
||||
|
||||
|
||||
-- | Click on a link defined by a CSS query
|
||||
--
|
||||
-- ==== __ Examples__
|
||||
--
|
||||
-- > get "/foobar"
|
||||
-- > clickOn "a#idofthelink"
|
||||
--
|
||||
-- @since 1.5.7
|
||||
clickOn :: Yesod site => Query -> YesodExample site ()
|
||||
clickOn query = do
|
||||
withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res ->
|
||||
case findAttributeBySelector (simpleBody res) query "href" of
|
||||
Left err -> failure $ query <> " did not parse: " <> T.pack (show err)
|
||||
Right [[match]] -> get match
|
||||
Right matches -> failure $ "Expected exactly one match for clickOn: got " <> T.pack (show matches)
|
||||
|
||||
|
||||
|
||||
-- | Simple way to set HTTP request body
|
||||
--
|
||||
-- ==== __ Examples__
|
||||
|
||||
@ -10,16 +10,16 @@ and it returns a list of the HTML fragments that matched the given query.
|
||||
Only a subset of the CSS spec is currently supported:
|
||||
|
||||
* By tag name: /table td a/
|
||||
|
||||
|
||||
* By class names: /.container .content/
|
||||
|
||||
* By Id: /#oneId/
|
||||
|
||||
* By attribute: /[hasIt]/, /[exact=match]/, /[contains*=text]/, /[starts^=with]/, /[ends$=with]/
|
||||
|
||||
|
||||
* Union: /a, span, p/
|
||||
|
||||
* Immediate children: /div > p/
|
||||
|
||||
* Immediate children: /div > p/
|
||||
|
||||
* Get jiggy with it: /div[data-attr=yeah] > .mon, .foo.bar div, #oneThing/
|
||||
|
||||
@ -27,6 +27,7 @@ Only a subset of the CSS spec is currently supported:
|
||||
|
||||
module Yesod.Test.TransversingCSS (
|
||||
findBySelector,
|
||||
findAttributeBySelector,
|
||||
HtmlLBS,
|
||||
Query,
|
||||
-- * For HXT hackers
|
||||
@ -41,7 +42,7 @@ where
|
||||
|
||||
import Yesod.Test.CssQuery
|
||||
import qualified Data.Text as T
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import qualified Control.Applicative
|
||||
import Text.XML
|
||||
import Text.XML.Cursor
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
@ -58,9 +59,30 @@ type HtmlLBS = L.ByteString
|
||||
--
|
||||
-- * Right: List of matching Html fragments.
|
||||
findBySelector :: HtmlLBS -> Query -> Either String [String]
|
||||
findBySelector html query = (\x -> map (renderHtml . toHtml . node) . runQuery x)
|
||||
Control.Applicative.<$> (Right $ fromDocument $ HD.parseLBS html)
|
||||
Control.Applicative.<*> parseQuery query
|
||||
findBySelector html query =
|
||||
map (renderHtml . toHtml . node) Control.Applicative.<$> findCursorsBySelector html query
|
||||
|
||||
-- | Perform a css 'Query' on 'Html'. Returns Either
|
||||
--
|
||||
-- * Left: Query parse error.
|
||||
--
|
||||
-- * Right: List of matching Cursors
|
||||
findCursorsBySelector :: HtmlLBS -> Query -> Either String [Cursor]
|
||||
findCursorsBySelector html query =
|
||||
runQuery (fromDocument $ HD.parseLBS html)
|
||||
Control.Applicative.<$> parseQuery query
|
||||
|
||||
-- | Perform a css 'Query' on 'Html'. Returns Either
|
||||
--
|
||||
-- * Left: Query parse error.
|
||||
--
|
||||
-- * Right: List of matching Cursors
|
||||
--
|
||||
-- @since 1.5.7
|
||||
findAttributeBySelector :: HtmlLBS -> Query -> T.Text -> Either String [[T.Text]]
|
||||
findAttributeBySelector html query attr =
|
||||
map (laxAttribute attr) Control.Applicative.<$> findCursorsBySelector html query
|
||||
|
||||
|
||||
-- Run a compiled query on Html, returning a list of matching Html fragments.
|
||||
runQuery :: Cursor -> [[SelectorGroup]] -> [Cursor]
|
||||
|
||||
@ -34,6 +34,7 @@ import Data.ByteString.Lazy.Char8 ()
|
||||
import qualified Data.Map as Map
|
||||
import qualified Text.HTML.DOM as HD
|
||||
import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415)
|
||||
import Control.Exception.Lifted(SomeException, try)
|
||||
|
||||
parseQuery_ :: Text -> [[SelectorGroup]]
|
||||
parseQuery_ = either error id . parseQuery
|
||||
@ -149,6 +150,18 @@ main = hspec $ do
|
||||
addToken
|
||||
statusIs 200
|
||||
bodyEquals "12345"
|
||||
yit "labels WForm" $ do
|
||||
get ("/wform" :: Text)
|
||||
statusIs 200
|
||||
|
||||
request $ do
|
||||
setMethod "POST"
|
||||
setUrl ("/wform" :: Text)
|
||||
byLabel "Some WLabel" "12345"
|
||||
fileByLabel "Some WFile" "test/main.hs" "text/plain"
|
||||
addToken
|
||||
statusIs 200
|
||||
bodyEquals "12345"
|
||||
yit "finding html" $ do
|
||||
get ("/html" :: Text)
|
||||
statusIs 200
|
||||
@ -169,6 +182,16 @@ main = hspec $ do
|
||||
addToken_ "body"
|
||||
statusIs 200
|
||||
bodyEquals "12345"
|
||||
yit "can follow a link via clickOn" $ do
|
||||
get ("/htmlWithLink" :: Text)
|
||||
clickOn "a#thelink"
|
||||
statusIs 200
|
||||
bodyEquals "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>"
|
||||
|
||||
get ("/htmlWithLink" :: Text)
|
||||
(bad :: Either SomeException ()) <- try (clickOn "a#nonexistentlink")
|
||||
assertEq "bad link" (isLeft bad) True
|
||||
|
||||
|
||||
ydescribe "utf8 paths" $ do
|
||||
yit "from path" $ do
|
||||
@ -323,9 +346,20 @@ app = liteApp $ do
|
||||
case mfoo of
|
||||
FormSuccess (foo, _) -> return $ toHtml foo
|
||||
_ -> defaultLayout widget
|
||||
onStatic "wform" $ dispatchTo $ do
|
||||
((mfoo, widget), _) <- runFormPost $ renderDivs $ wFormToAForm $ do
|
||||
field1F <- wreq textField "Some WLabel" Nothing
|
||||
field2F <- wreq fileField "Some WFile" Nothing
|
||||
|
||||
return $ (,) Control.Applicative.<$> field1F <*> field2F
|
||||
case mfoo of
|
||||
FormSuccess (foo, _) -> return $ toHtml foo
|
||||
_ -> defaultLayout widget
|
||||
onStatic "html" $ dispatchTo $
|
||||
return ("<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>" :: Text)
|
||||
|
||||
onStatic "htmlWithLink" $ dispatchTo $
|
||||
return ("<html><head><title>A link</title></head><body><a href=\"/html\" id=\"thelink\">Link!</a></body></html>" :: Text)
|
||||
onStatic "labels" $ dispatchTo $
|
||||
return ("<html><label><input type='checkbox' name='fooname' id='foobar'>Foo Bar</label></html>" :: Text)
|
||||
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-test
|
||||
version: 1.5.4.1
|
||||
version: 1.5.8
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Nubis <nubis@woobiz.com.ar>
|
||||
@ -58,7 +58,7 @@ test-suite test
|
||||
, containers
|
||||
, html-conduit
|
||||
, yesod-core
|
||||
, yesod-form
|
||||
, yesod-form >= 1.4.14
|
||||
, text
|
||||
, wai
|
||||
, lifted-base
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
## 0.2.6
|
||||
|
||||
* Fix warnings
|
||||
|
||||
## 0.2.5
|
||||
|
||||
* Allow to start websockets with custom ConnectionOptions with `webSocketsOptions` and `webSocketsOptionsWith`
|
||||
|
||||
@ -3,10 +3,10 @@ import Yesod.Core
|
||||
import Yesod.WebSockets
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Control.Monad (forever)
|
||||
import Control.Monad.Trans.Reader
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Data.Time
|
||||
import Conduit
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.List
|
||||
|
||||
data App = App
|
||||
|
||||
@ -25,7 +25,7 @@ timeSource = forever $ do
|
||||
getHomeR :: Handler Html
|
||||
getHomeR = do
|
||||
webSockets $ race_
|
||||
(sourceWS $$ mapC TL.toUpper =$ sinkWSText)
|
||||
(sourceWS $$ Data.Conduit.List.map TL.toUpper =$ sinkWSText)
|
||||
(timeSource $$ sinkWSText)
|
||||
defaultLayout $
|
||||
toWidget
|
||||
@ -43,6 +43,9 @@ getHomeR = do
|
||||
conn.onmessage = function(e) {
|
||||
document.write("<p>" + e.data + "</p>");
|
||||
};
|
||||
conn.onclose = function () {
|
||||
document.write("<p>Connection Closed</p>");
|
||||
};
|
||||
|]
|
||||
|
||||
main :: IO ()
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-websockets
|
||||
version: 0.2.5
|
||||
version: 0.2.6
|
||||
synopsis: WebSockets support for Yesod
|
||||
description: WebSockets support for Yesod
|
||||
homepage: https://github.com/yesodweb/yesod
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
## 1.4.5
|
||||
|
||||
* Fix warnings
|
||||
|
||||
## 1.4.4
|
||||
|
||||
* Reduce dependencies
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod
|
||||
version: 1.4.4
|
||||
version: 1.4.5
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user