Compare commits
No commits in common. "master" and "update-azure" have entirely different histories.
master
...
update-azu
25
.azure/azure-linux-template.yml
Normal file
25
.azure/azure-linux-template.yml
Normal file
@ -0,0 +1,25 @@
|
||||
jobs:
|
||||
- job: ${{ parameters.name }}
|
||||
timeoutInMinutes: 180
|
||||
pool:
|
||||
vmImage: ${{ parameters.vmImage }}
|
||||
strategy:
|
||||
matrix:
|
||||
GHC 8.2:
|
||||
ARGS: "--resolver lts-11"
|
||||
GHC 8.4:
|
||||
ARGS: "--resolver lts-12"
|
||||
GHC 8.6:
|
||||
ARGS: "--resolver lts-14"
|
||||
GHC 8.8:
|
||||
ARGS: "--resolver lts-15"
|
||||
steps:
|
||||
- script: |
|
||||
export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
|
||||
export PATH=$HOME/.local/bin:$PATH
|
||||
mkdir -p ~/.local/bin
|
||||
curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
|
||||
stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
|
||||
env:
|
||||
OS_NAME: ${{ parameters.os }}
|
||||
displayName: 'Build and test'
|
||||
25
.azure/azure-osx-template.yml
Normal file
25
.azure/azure-osx-template.yml
Normal file
@ -0,0 +1,25 @@
|
||||
jobs:
|
||||
- job: ${{ parameters.name }}
|
||||
timeoutInMinutes: 120
|
||||
pool:
|
||||
vmImage: ${{ parameters.vmImage }}
|
||||
strategy:
|
||||
matrix:
|
||||
GHC 8.2:
|
||||
ARGS: "--resolver lts-11"
|
||||
GHC 8.4:
|
||||
ARGS: "--resolver lts-12"
|
||||
GHC 8.6:
|
||||
ARGS: "--resolver lts-14"
|
||||
GHC 8.8:
|
||||
ARGS: "--resolver lts-15"
|
||||
steps:
|
||||
- script: |
|
||||
export PATH=$HOME/.local/bin:$PATH
|
||||
export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
|
||||
mkdir -p ~/.local/bin
|
||||
curl -skL https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;
|
||||
stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
|
||||
env:
|
||||
OS_NAME: ${{ parameters.os }}
|
||||
displayName: 'Build and test'
|
||||
30
.azure/azure-pipelines.yml
Normal file
30
.azure/azure-pipelines.yml
Normal file
@ -0,0 +1,30 @@
|
||||
# This is the complex Azure configuration, which is intended for use
|
||||
# on open source libraries which need compatibility across multiple GHC
|
||||
# versions, must work with cabal-install, and should be
|
||||
# cross-platform. For more information and other options, see:
|
||||
#
|
||||
# https://docs.haskellstack.org/en/stable/azure_ci/
|
||||
#
|
||||
# Copy these contents into the root directory of your Github project in a file
|
||||
# named azure-pipelines.yml
|
||||
#
|
||||
# For better organization, you split various jobs into seprate parts
|
||||
# and each of them are controlled via individual file.
|
||||
jobs:
|
||||
- template: azure-linux-template.yml
|
||||
parameters:
|
||||
name: Linux
|
||||
vmImage: ubuntu-latest
|
||||
os: linux
|
||||
|
||||
- template: azure-osx-template.yml
|
||||
parameters:
|
||||
name: macOS
|
||||
vmImage: macOS-latest
|
||||
os: osx
|
||||
|
||||
- template: azure-windows-template.yml
|
||||
parameters:
|
||||
name: Windows
|
||||
vmImage: windows-latest
|
||||
os: windows
|
||||
22
.azure/azure-windows-template.yml
Normal file
22
.azure/azure-windows-template.yml
Normal file
@ -0,0 +1,22 @@
|
||||
jobs:
|
||||
- job: ${{ parameters.name }}
|
||||
timeoutInMinutes: 120
|
||||
pool:
|
||||
vmImage: ${{ parameters.vmImage }}
|
||||
strategy:
|
||||
matrix:
|
||||
GHC 8.2:
|
||||
ARGS: "--resolver lts-11"
|
||||
GHC 8.4:
|
||||
ARGS: "--resolver lts-12"
|
||||
GHC 8.6:
|
||||
ARGS: "--resolver lts-14"
|
||||
steps:
|
||||
- bash: |
|
||||
export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
|
||||
curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip
|
||||
unzip -o /usr/bin/stack.zip -d /usr/bin/
|
||||
stack $ARGS test --bench --no-run-benchmarks
|
||||
env:
|
||||
OS_NAME: ${{ parameters.os }}
|
||||
displayName: 'Build and test'
|
||||
56
.github/workflows/tests.yml
vendored
56
.github/workflows/tests.yml
vendored
@ -1,56 +0,0 @@
|
||||
name: Tests
|
||||
|
||||
on:
|
||||
pull_request:
|
||||
push:
|
||||
branches:
|
||||
- master
|
||||
|
||||
jobs:
|
||||
build:
|
||||
name: CI
|
||||
runs-on: ${{ matrix.os }}
|
||||
strategy:
|
||||
fail-fast: false
|
||||
matrix:
|
||||
os: [ubuntu-latest, macos-latest, windows-latest]
|
||||
args:
|
||||
#- "--resolver nightly"
|
||||
- "--resolver nightly-2022-02-11"
|
||||
- "--resolver lts-18"
|
||||
- "--resolver lts-16"
|
||||
- "--resolver lts-14"
|
||||
- "--resolver lts-12"
|
||||
- "--resolver lts-11"
|
||||
# Bugs in GHC make it crash too often to be worth running
|
||||
exclude:
|
||||
- os: windows-latest
|
||||
args: "--resolver nightly"
|
||||
- os: macos-latest
|
||||
args: "--resolver lts-16"
|
||||
- os: macos-latest
|
||||
args: "--resolver lts-14"
|
||||
- os: macos-latest
|
||||
args: "--resolver lts-12"
|
||||
- os: macos-latest
|
||||
args: "--resolver lts-11"
|
||||
|
||||
steps:
|
||||
- name: Clone project
|
||||
uses: actions/checkout@v2
|
||||
|
||||
# Getting weird OS X errors...
|
||||
# - name: Cache dependencies
|
||||
# uses: actions/cache@v1
|
||||
# with:
|
||||
# path: ~/.stack
|
||||
# key: ${{ runner.os }}-${{ matrix.resolver }}-${{ hashFiles('stack.yaml') }}
|
||||
# restore-keys: |
|
||||
# ${{ runner.os }}-${{ matrix.resolver }}-
|
||||
|
||||
- name: Build and run tests
|
||||
shell: bash
|
||||
run: |
|
||||
set -ex
|
||||
stack --version
|
||||
stack test --fast --no-terminal ${{ matrix.args }}
|
||||
2
.gitignore
vendored
2
.gitignore
vendored
@ -25,5 +25,3 @@ tarballs/
|
||||
|
||||
# OS X
|
||||
.DS_Store
|
||||
*.yaml.lock
|
||||
dist-newstyle/
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
|
||||
[](https://dev.azure.com/yesodweb/yesod/_build/latest?definitionId=3&branchName=master)
|
||||
|
||||
# Yesod Web Framework
|
||||
|
||||
|
||||
@ -1,15 +0,0 @@
|
||||
packages:
|
||||
yesod-core
|
||||
yesod-static
|
||||
yesod-persistent
|
||||
yesod-newsfeed
|
||||
yesod-form
|
||||
yesod-form-multi
|
||||
yesod-auth
|
||||
yesod-auth-oauth
|
||||
yesod-sitemap
|
||||
yesod-test
|
||||
yesod-bin
|
||||
yesod
|
||||
yesod-eventsource
|
||||
yesod-websockets
|
||||
@ -21,7 +21,7 @@ data Wiki = Wiki
|
||||
}
|
||||
|
||||
-- | A typeclass that all master sites that want a Wiki must implement. A
|
||||
-- master must be able to render form messages, as we use yesod-form for
|
||||
-- master must be able to render form messages, as we use yesod-forms for
|
||||
-- processing user input.
|
||||
class (RenderMessage master FormMessage, Yesod master) => YesodWiki master where
|
||||
-- | Write protection. By default, no protection.
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
resolver: lts-18.3
|
||||
resolver: lts-15.5
|
||||
packages:
|
||||
- ./yesod-core
|
||||
- ./yesod-static
|
||||
@ -14,6 +14,3 @@ packages:
|
||||
- ./yesod
|
||||
- ./yesod-eventsource
|
||||
- ./yesod-websockets
|
||||
|
||||
extra-deps:
|
||||
- attoparsec-aeson-2.1.0.0
|
||||
|
||||
@ -3,17 +3,10 @@
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages:
|
||||
- completed:
|
||||
hackage: attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
|
||||
pantry-tree:
|
||||
sha256: 294c3a8a19a7ddad58097e18c624c6b34894b3c4a4cc490759cb31d842db242a
|
||||
size: 114
|
||||
original:
|
||||
hackage: attoparsec-aeson-2.1.0.0
|
||||
packages: []
|
||||
snapshots:
|
||||
- completed:
|
||||
sha256: 694573e96dca34db5636edb1fe6c96bb233ca0f9fb96c1ead1671cdfa9bd73e9
|
||||
size: 585603
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/3.yaml
|
||||
original: lts-18.3
|
||||
size: 491372
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/5.yaml
|
||||
sha256: 1b549cfff328040c382a70a84a2087aac8dab6d778bf92f32a93a771a1980dfc
|
||||
original: lts-15.5
|
||||
|
||||
@ -1,13 +1,3 @@
|
||||
# ChangeLog for yesod-auth-oauth
|
||||
|
||||
## 1.6.1
|
||||
|
||||
* Allow newer GHC
|
||||
|
||||
## 1.6.0.3
|
||||
|
||||
* Allow yesod-form 1.7
|
||||
|
||||
## 1.6.0.2
|
||||
|
||||
* Remove unnecessary deriving of Typeable
|
||||
|
||||
@ -18,6 +18,7 @@ import Control.Applicative as A ((<$>), (<*>))
|
||||
import Control.Arrow ((***))
|
||||
import UnliftIO.Exception
|
||||
import Control.Monad.IO.Class
|
||||
import UnliftIO (MonadUnliftIO)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
@ -52,9 +53,14 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
|
||||
oauthSessionName = "__oauth_token_secret"
|
||||
|
||||
dispatch
|
||||
:: Text
|
||||
:: ( MonadHandler m
|
||||
, master ~ HandlerSite m
|
||||
, Auth ~ SubHandlerSite m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Text
|
||||
-> [Text]
|
||||
-> AuthHandler master TypedContent
|
||||
-> m TypedContent
|
||||
dispatch "GET" ["forward"] = do
|
||||
render <- getUrlRender
|
||||
tm <- getRouteToParent
|
||||
|
||||
@ -1,6 +1,5 @@
|
||||
cabal-version: >= 1.10
|
||||
name: yesod-auth-oauth
|
||||
version: 1.6.1
|
||||
version: 1.6.0.2
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Hiromi Ishii
|
||||
@ -8,21 +7,21 @@ maintainer: Michael Litchard
|
||||
synopsis: OAuth Authentication for Yesod.
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.6.0
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-auth-oauth>
|
||||
extra-source-files: README.md ChangeLog.md
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
build-depends: authenticate-oauth >= 1.5 && < 1.8
|
||||
build-depends: authenticate-oauth >= 1.5 && < 1.7
|
||||
, base >= 4.10 && < 5
|
||||
, bytestring >= 0.9.1.4
|
||||
, text >= 0.7
|
||||
, unliftio
|
||||
, yesod-auth >= 1.6 && < 1.7
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, yesod-form >= 1.6 && < 1.8
|
||||
, yesod-form >= 1.6 && < 1.7
|
||||
exposed-modules: Yesod.Auth.OAuth
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
@ -1,37 +1,5 @@
|
||||
# ChangeLog for yesod-auth
|
||||
|
||||
## 1.6.11.2
|
||||
|
||||
* Add support for aeson 2.2 [#1820](https://github.com/yesodweb/yesod/pull/1820)
|
||||
|
||||
## 1.6.11.1
|
||||
|
||||
* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
|
||||
|
||||
## 1.6.11
|
||||
|
||||
* Add support for aeson 2
|
||||
|
||||
## 1.6.10.5
|
||||
|
||||
* Fix German translations of AuthMessage [#1741](https://github.com/yesodweb/yesod/pull/1741)
|
||||
|
||||
## 1.6.10.4
|
||||
|
||||
* Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737)
|
||||
|
||||
## 1.6.10.3
|
||||
|
||||
* Relax bounds for yesod-form 1.7
|
||||
|
||||
## 1.6.10.2
|
||||
|
||||
* Relax bounds for persistent 2.12
|
||||
|
||||
## 1.6.10.1
|
||||
|
||||
* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)
|
||||
|
||||
## 1.6.10
|
||||
|
||||
* Updated `AuthMessage` data type in `Yesod.Auth.Message` to accommodate registration flow where password is supplied initially: deprecated `AddressVerified` and split into `EmailVerifiedChangePass` and `EmailVerified`
|
||||
|
||||
@ -6,7 +6,6 @@ BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available
|
||||
from Hackage as well. If you've written such an add-on, please notify me so
|
||||
that it can be added to this description.
|
||||
|
||||
* [yesod-auth-oauth2](https://hackage.haskell.org/package/yesod-auth-oauth2): Library to authenticate with OAuth 2.0.
|
||||
* [yesod-auth-account](http://hackage.haskell.org/package/yesod-auth-account): An account authentication plugin for Yesod
|
||||
* [yesod-auth-hashdb](http://www.stackage.org/package/yesod-auth-hashdb): The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security.
|
||||
* [yesod-auth-bcrypt](https://hackage.haskell.org/package/yesod-auth-bcrypt): An alternative to the HashDB module.
|
||||
* [yesod-auth-bcrypt](https://github.com/ollieh/yesod-auth-bcrypt/): An alternative to the HashDB module.
|
||||
|
||||
@ -52,6 +52,7 @@ import Control.Monad.Trans.Maybe
|
||||
import UnliftIO (withRunInIO, MonadUnliftIO)
|
||||
|
||||
import Yesod.Auth.Routes
|
||||
import Data.Aeson hiding (json)
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Data.Text (Text)
|
||||
@ -73,7 +74,6 @@ import Control.Exception (Exception)
|
||||
import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
|
||||
import qualified Control.Monad.Trans.Writer as Writer
|
||||
import Control.Monad (void)
|
||||
import Data.Kind (Type)
|
||||
|
||||
type AuthRoute = Route Auth
|
||||
|
||||
@ -452,7 +452,7 @@ $nothing
|
||||
<p>Not logged in.
|
||||
|]
|
||||
jsonCreds creds =
|
||||
toJSON $ Map.fromList
|
||||
Object $ Map.fromList
|
||||
[ (T.pack "logged_in", Bool $ maybe False (const True) creds)
|
||||
]
|
||||
|
||||
@ -533,7 +533,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
|
||||
-- > AuthEntity MySite ~ User
|
||||
--
|
||||
-- @since 1.2.0
|
||||
type AuthEntity master :: Type
|
||||
type AuthEntity master :: *
|
||||
type AuthEntity master = KeyEntity (AuthId master)
|
||||
|
||||
getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)
|
||||
|
||||
@ -1,9 +1,8 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
-- | Provides a dummy authentication module that simply lets a user specify
|
||||
-- their identifier. This is not intended for real world use, just for
|
||||
-- testing. This plugin supports form submissions via JSON (since 1.6.8).
|
||||
@ -36,12 +35,12 @@ module Yesod.Auth.Dummy
|
||||
( authDummy
|
||||
) where
|
||||
|
||||
import Data.Aeson.Types (Parser, Result (..))
|
||||
import Yesod.Auth
|
||||
import Yesod.Form (runInputPost, textField, ireq)
|
||||
import Yesod.Core
|
||||
import Data.Text (Text)
|
||||
import Data.Aeson.Types (Result(..), Parser)
|
||||
import qualified Data.Aeson.Types as A (parseEither, withObject)
|
||||
import Data.Text (Text)
|
||||
import Yesod.Auth
|
||||
import Yesod.Core
|
||||
import Yesod.Form (ireq, runInputPost, textField)
|
||||
|
||||
identParser :: Value -> Parser Text
|
||||
identParser = A.withObject "Ident" (.: "ident")
|
||||
@ -50,7 +49,6 @@ authDummy :: YesodAuth m => AuthPlugin m
|
||||
authDummy =
|
||||
AuthPlugin "dummy" dispatch login
|
||||
where
|
||||
dispatch :: Text -> [Text] -> AuthHandler m TypedContent
|
||||
dispatch "POST" [] = do
|
||||
(jsonResult :: Result Value) <- parseCheckJsonBody
|
||||
eIdent <- case jsonResult of
|
||||
|
||||
@ -31,16 +31,16 @@
|
||||
-- = Using JSON Endpoints
|
||||
--
|
||||
-- We are assuming that you have declared auth route as follows
|
||||
--
|
||||
--
|
||||
-- @
|
||||
-- /auth AuthR Auth getAuth
|
||||
-- @
|
||||
--
|
||||
--
|
||||
-- If you are using a different route, then you have to adjust the
|
||||
-- endpoints accordingly.
|
||||
--
|
||||
-- * Registration
|
||||
--
|
||||
--
|
||||
-- @
|
||||
-- Endpoint: \/auth\/page\/email\/register
|
||||
-- Method: POST
|
||||
@ -49,9 +49,9 @@
|
||||
-- "password": "myStrongPassword" (optional)
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
--
|
||||
-- * Forgot password
|
||||
--
|
||||
--
|
||||
-- @
|
||||
-- Endpoint: \/auth\/page\/email\/forgot-password
|
||||
-- Method: POST
|
||||
@ -59,16 +59,16 @@
|
||||
-- @
|
||||
--
|
||||
-- * Login
|
||||
--
|
||||
--
|
||||
-- @
|
||||
-- Endpoint: \/auth\/page\/email\/login
|
||||
-- Method: POST
|
||||
-- JSON Data: {
|
||||
-- JSON Data: {
|
||||
-- "email": "myemail@domain.com",
|
||||
-- "password": "myStrongPassword"
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
--
|
||||
-- * Set new password
|
||||
--
|
||||
-- @
|
||||
@ -117,30 +117,28 @@ module Yesod.Auth.Email
|
||||
, defaultRegisterHelper
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import qualified Crypto.Hash as H
|
||||
import qualified Crypto.Nonce as Nonce
|
||||
import Data.Aeson.Types (Parser, Result (..), parseMaybe,
|
||||
withObject, (.:?))
|
||||
import Data.ByteArray (convert)
|
||||
import Data.ByteString.Base16 as B16
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text as TS
|
||||
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Data.Time (addUTCTime, getCurrentTime)
|
||||
import Safe (readMay)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import qualified Text.Email.Validate
|
||||
import Yesod.Auth
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PS
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Types (TypedContent (TypedContent))
|
||||
import Yesod.Form
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PS
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import qualified Crypto.Hash as H
|
||||
import qualified Crypto.Nonce as Nonce
|
||||
import Data.ByteString.Base16 as B16
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as TS
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Data.Time (addUTCTime, getCurrentTime)
|
||||
import Safe (readMay)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import qualified Text.Email.Validate
|
||||
import Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
|
||||
import Data.Maybe (isJust)
|
||||
import Data.ByteArray (convert)
|
||||
|
||||
loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
|
||||
loginR = PluginR "email" ["login"]
|
||||
@ -242,7 +240,7 @@ class ( YesodAuth site
|
||||
--
|
||||
-- @since 1.4.20
|
||||
hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
|
||||
hashAndSaltPassword password = liftIO $ saltPass password
|
||||
hashAndSaltPassword = liftIO . saltPass
|
||||
|
||||
-- | Verify a password matches the stored password for the given account.
|
||||
--
|
||||
@ -434,14 +432,13 @@ authEmail :: (YesodAuthEmail m) => AuthPlugin m
|
||||
authEmail =
|
||||
AuthPlugin "email" dispatch emailLoginHandler
|
||||
where
|
||||
dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent
|
||||
dispatch "GET" ["register"] = getRegisterR >>= sendResponse
|
||||
dispatch "POST" ["register"] = postRegisterR >>= sendResponse
|
||||
dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse
|
||||
dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse
|
||||
dispatch "GET" ["verify", eid, verkey] =
|
||||
case fromPathPiece eid of
|
||||
Nothing -> notFound
|
||||
Nothing -> notFound
|
||||
Just eid' -> getVerifyR eid' verkey False >>= sendResponse
|
||||
dispatch "GET" ["verify", eid, verkey, hasSetPass] =
|
||||
case fromPathPiece eid of
|
||||
@ -488,13 +485,13 @@ defaultEmailLoginHandler toParent = do
|
||||
let userRes = UserLoginForm Control.Applicative.<$> emailRes
|
||||
Control.Applicative.<*> passwordRes
|
||||
let widget = do
|
||||
[whamlet|
|
||||
#{extra}
|
||||
<div>
|
||||
^{fvInput emailView}
|
||||
<div>
|
||||
^{fvInput passwordView}
|
||||
|]
|
||||
[whamlet|
|
||||
#{extra}
|
||||
<div>
|
||||
^{fvInput emailView}
|
||||
<div>
|
||||
^{fvInput passwordView}
|
||||
|]
|
||||
|
||||
return (userRes, widget)
|
||||
emailSettings emailMsg = do
|
||||
@ -548,11 +545,11 @@ defaultRegisterHandler = do
|
||||
|
||||
let userRes = UserForm <$> emailRes
|
||||
let widget = do
|
||||
[whamlet|
|
||||
#{extra}
|
||||
^{fvLabel emailView}
|
||||
^{fvInput emailView}
|
||||
|]
|
||||
[whamlet|
|
||||
#{extra}
|
||||
^{fvLabel emailView}
|
||||
^{fvInput emailView}
|
||||
|]
|
||||
|
||||
return (userRes, widget)
|
||||
|
||||
@ -579,7 +576,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
|
||||
_ -> do
|
||||
(creds :: Result Value) <- parseCheckJsonBody
|
||||
return $ case creds of
|
||||
Error _ -> Nothing
|
||||
Error _ -> Nothing
|
||||
Success val -> parseMaybe parseRegister val
|
||||
|
||||
let eidentifier = case creds of
|
||||
@ -592,7 +589,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
|
||||
|
||||
let mpass = case (forgotPassword, creds) of
|
||||
(False, Just (_, mp)) -> mp
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
case eidentifier of
|
||||
Left failMsg -> loginErrorMessageI dest failMsg
|
||||
@ -623,7 +620,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
|
||||
then sendConfirmationEmail creds
|
||||
else case emailPreviouslyRegisteredResponse identifier of
|
||||
Just response -> response
|
||||
Nothing -> sendConfirmationEmail creds
|
||||
Nothing -> sendConfirmationEmail creds
|
||||
where sendConfirmationEmail (lid, _, verKey, email) = do
|
||||
render <- getUrlRender
|
||||
tp <- getRouteToParent
|
||||
@ -662,11 +659,11 @@ defaultForgotPasswordHandler = do
|
||||
|
||||
let forgotPasswordRes = ForgotPasswordForm <$> emailRes
|
||||
let widget = do
|
||||
[whamlet|
|
||||
#{extra}
|
||||
^{fvLabel emailView}
|
||||
^{fvInput emailView}
|
||||
|]
|
||||
[whamlet|
|
||||
#{extra}
|
||||
^{fvLabel emailView}
|
||||
^{fvInput emailView}
|
||||
|]
|
||||
return (forgotPasswordRes, widget)
|
||||
|
||||
emailSettings =
|
||||
@ -742,7 +739,7 @@ postLoginR = do
|
||||
_ -> do
|
||||
(creds :: Result Value) <- parseCheckJsonBody
|
||||
case creds of
|
||||
Error _ -> return Nothing
|
||||
Error _ -> return Nothing
|
||||
Success val -> return $ parseMaybe parseCreds val
|
||||
|
||||
case midentifier of
|
||||
@ -782,8 +779,8 @@ getPasswordR = do
|
||||
maid <- maybeAuthId
|
||||
case maid of
|
||||
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
|
||||
Just aid -> do
|
||||
needOld <- needOldPassword aid
|
||||
Just _ -> do
|
||||
needOld <- maybe (return True) needOldPassword maid
|
||||
setPasswordHandler needOld
|
||||
|
||||
-- | Default implementation of 'setPasswordHandler'.
|
||||
@ -811,29 +808,29 @@ defaultSetPasswordHandler needOld = do
|
||||
|
||||
let passwordFormRes = PasswordForm <$> currentPasswordRes <*> newPasswordRes <*> confirmPasswordRes
|
||||
let widget = do
|
||||
[whamlet|
|
||||
#{extra}
|
||||
<table>
|
||||
$if needOld
|
||||
<tr>
|
||||
<th>
|
||||
^{fvLabel currentPasswordView}
|
||||
<td>
|
||||
^{fvInput currentPasswordView}
|
||||
<tr>
|
||||
<th>
|
||||
^{fvLabel newPasswordView}
|
||||
<td>
|
||||
^{fvInput newPasswordView}
|
||||
<tr>
|
||||
<th>
|
||||
^{fvLabel confirmPasswordView}
|
||||
<td>
|
||||
^{fvInput confirmPasswordView}
|
||||
<tr>
|
||||
<td colspan="2">
|
||||
<input type=submit value=_{Msg.SetPassTitle}>
|
||||
|]
|
||||
[whamlet|
|
||||
#{extra}
|
||||
<table>
|
||||
$if needOld
|
||||
<tr>
|
||||
<th>
|
||||
^{fvLabel currentPasswordView}
|
||||
<td>
|
||||
^{fvInput currentPasswordView}
|
||||
<tr>
|
||||
<th>
|
||||
^{fvLabel newPasswordView}
|
||||
<td>
|
||||
^{fvInput newPasswordView}
|
||||
<tr>
|
||||
<th>
|
||||
^{fvLabel confirmPasswordView}
|
||||
<td>
|
||||
^{fvInput confirmPasswordView}
|
||||
<tr>
|
||||
<td colspan="2">
|
||||
<input type=submit value=_{Msg.SetPassTitle}>
|
||||
|]
|
||||
|
||||
return (passwordFormRes, widget)
|
||||
currentPasswordSettings =
|
||||
@ -873,7 +870,7 @@ postPasswordR = do
|
||||
maid <- maybeAuthId
|
||||
(creds :: Result Value) <- parseCheckJsonBody
|
||||
let jcreds = case creds of
|
||||
Error _ -> Nothing
|
||||
Error _ -> Nothing
|
||||
Success val -> parseMaybe parsePassword val
|
||||
let doJsonParsing = isJust jcreds
|
||||
case maid of
|
||||
@ -885,7 +882,7 @@ postPasswordR = do
|
||||
res <- runInputPostResult $ ireq textField "current"
|
||||
let fcurrent = case res of
|
||||
FormSuccess currentPass -> Just currentPass
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
let current = if doJsonParsing
|
||||
then getThird jcreds
|
||||
else fcurrent
|
||||
@ -904,9 +901,9 @@ postPasswordR = do
|
||||
where
|
||||
msgOk = Msg.PassUpdated
|
||||
getThird (Just (_,_,t)) = t
|
||||
getThird Nothing = Nothing
|
||||
getThird Nothing = Nothing
|
||||
getNewConfirm (Just (a,b,_)) = Just (a,b)
|
||||
getNewConfirm _ = Nothing
|
||||
getNewConfirm _ = Nothing
|
||||
confirmPassword aid tm jcreds = do
|
||||
res <- runInputPostResult $ (,)
|
||||
<$> ireq textField "new"
|
||||
@ -915,7 +912,7 @@ postPasswordR = do
|
||||
then getNewConfirm jcreds
|
||||
else case res of
|
||||
FormSuccess res' -> Just res'
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
case creds of
|
||||
Nothing -> loginErrorMessageI setpassR Msg.PassMismatch
|
||||
Just (new, confirm) ->
|
||||
@ -935,7 +932,7 @@ postPasswordR = do
|
||||
|
||||
mr <- getMessageRender
|
||||
selectRep $ do
|
||||
provideRep $
|
||||
provideRep $
|
||||
fmap asHtml $ redirect $ afterPasswordRoute y
|
||||
provideJsonMessage (mr msgOk)
|
||||
|
||||
|
||||
@ -53,61 +53,55 @@ module Yesod.Auth.GoogleEmail2
|
||||
, pid
|
||||
) where
|
||||
|
||||
import Yesod.Auth (Auth, AuthHandler,
|
||||
AuthPlugin (AuthPlugin),
|
||||
AuthRoute, Creds (Creds),
|
||||
Route (PluginR), YesodAuth,
|
||||
logoutDest, runHttpRequest,
|
||||
setCredsRedirect)
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
import Yesod.Core (HandlerSite, MonadHandler,
|
||||
TypedContent, addMessage,
|
||||
getRouteToParent, getUrlRender,
|
||||
getYesod, invalidArgs, liftIO,
|
||||
liftSubHandler, lookupGetParam,
|
||||
lookupSession, notFound, redirect,
|
||||
setSession, toHtml, whamlet, (.:))
|
||||
import Yesod.Auth (Auth, AuthPlugin (AuthPlugin),
|
||||
AuthRoute, Creds (Creds),
|
||||
Route (PluginR), YesodAuth,
|
||||
runHttpRequest, setCredsRedirect,
|
||||
logoutDest, AuthHandler)
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
import Yesod.Core (HandlerSite, MonadHandler,
|
||||
TypedContent, getRouteToParent,
|
||||
getUrlRender, invalidArgs,
|
||||
liftIO, lookupGetParam,
|
||||
lookupSession, notFound, redirect,
|
||||
setSession, whamlet, (.:),
|
||||
addMessage, getYesod,
|
||||
toHtml, liftSubHandler)
|
||||
|
||||
|
||||
import Blaze.ByteString.Builder (fromByteString, toByteString)
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Control.Arrow (second)
|
||||
import Control.Monad (unless, when)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import qualified Crypto.Nonce as Nonce
|
||||
import Data.Aeson ((.:?))
|
||||
import qualified Data.Aeson as A
|
||||
import Blaze.ByteString.Builder (fromByteString, toByteString)
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Control.Arrow (second)
|
||||
import Control.Monad (unless, when)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import qualified Crypto.Nonce as Nonce
|
||||
import Data.Aeson ((.:?))
|
||||
import qualified Data.Aeson as A
|
||||
#if MIN_VERSION_aeson(1,0,0)
|
||||
import qualified Data.Aeson.Text as A
|
||||
import qualified Data.Aeson.Text as A
|
||||
#else
|
||||
import qualified Data.Aeson.Encode as A
|
||||
import qualified Data.Aeson.Encode as A
|
||||
#endif
|
||||
import Data.Aeson.Parser (json')
|
||||
import Data.Aeson.Types (FromJSON (parseJSON), parseEither,
|
||||
parseMaybe, withObject, withText)
|
||||
import Data.Aeson.Parser (json')
|
||||
import Data.Aeson.Types (FromJSON (parseJSON), parseEither,
|
||||
parseMaybe, withObject, withText)
|
||||
import Data.Conduit
|
||||
import Data.Conduit.Attoparsec (sinkParser)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Monoid (mappend)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TL
|
||||
import Network.HTTP.Client (Manager, requestHeaders,
|
||||
responseBody, urlEncodedBody)
|
||||
import qualified Network.HTTP.Client as HTTP
|
||||
import Data.Conduit.Attoparsec (sinkParser)
|
||||
import qualified Data.HashMap.Strict as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Monoid (mappend)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TL
|
||||
import Network.HTTP.Client (Manager, requestHeaders,
|
||||
responseBody, urlEncodedBody)
|
||||
import qualified Network.HTTP.Client as HTTP
|
||||
import Network.HTTP.Client.Conduit (Request, bodyReaderSource)
|
||||
import Network.HTTP.Conduit (http)
|
||||
import Network.HTTP.Types (renderQueryText)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
#if MIN_VERSION_aeson(2, 0, 0)
|
||||
import qualified Data.Aeson.Key
|
||||
import qualified Data.Aeson.KeyMap
|
||||
#else
|
||||
import qualified Data.HashMap.Strict as M
|
||||
#endif
|
||||
import Network.HTTP.Conduit (http)
|
||||
import Network.HTTP.Types (renderQueryText)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
|
||||
-- | Plugin identifier. This is used to identify the plugin used for
|
||||
@ -245,7 +239,7 @@ authPlugin storeToken clientID clientSecret =
|
||||
value <- makeHttpRequest req
|
||||
token@(Token accessToken' tokenType') <-
|
||||
case parseEither parseJSON value of
|
||||
Left e -> error e
|
||||
Left e -> error e
|
||||
Right t -> return t
|
||||
|
||||
unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType'
|
||||
@ -253,18 +247,16 @@ authPlugin storeToken clientID clientSecret =
|
||||
-- User's access token is saved for further access to API
|
||||
when storeToken $ setSession accessTokenKey accessToken'
|
||||
|
||||
personValReq <- personValueRequest token
|
||||
personValue <- makeHttpRequest personValReq
|
||||
|
||||
personValue <- makeHttpRequest =<< personValueRequest token
|
||||
person <- case parseEither parseJSON personValue of
|
||||
Left e -> error e
|
||||
Left e -> error e
|
||||
Right x -> return x
|
||||
|
||||
email <-
|
||||
case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of
|
||||
[e] -> return e
|
||||
[] -> error "No account email"
|
||||
x -> error $ "Too many account emails: " ++ show x
|
||||
[] -> error "No account email"
|
||||
x -> error $ "Too many account emails: " ++ show x
|
||||
setCredsRedirect $ Creds pid email $ allPersonInfo personValue
|
||||
|
||||
dispatch _ _ = notFound
|
||||
@ -458,16 +450,16 @@ data RelationshipStatus = Single -- ^ Person is single
|
||||
|
||||
instance FromJSON RelationshipStatus where
|
||||
parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of
|
||||
"single" -> Single
|
||||
"in_a_relationship" -> InRelationship
|
||||
"engaged" -> Engaged
|
||||
"married" -> Married
|
||||
"its_complicated" -> Complicated
|
||||
"open_relationship" -> OpenRelationship
|
||||
"widowed" -> Widowed
|
||||
"in_domestic_partnership" -> DomesticPartnership
|
||||
"in_civil_union" -> CivilUnion
|
||||
_ -> RelationshipStatus t
|
||||
"single" -> Single
|
||||
"in_a_relationship" -> InRelationship
|
||||
"engaged" -> Engaged
|
||||
"married" -> Married
|
||||
"its_complicated" -> Complicated
|
||||
"open_relationship" -> OpenRelationship
|
||||
"widowed" -> Widowed
|
||||
"in_domestic_partnership" -> DomesticPartnership
|
||||
"in_civil_union" -> CivilUnion
|
||||
_ -> RelationshipStatus t
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | The URI of the person's profile photo.
|
||||
@ -593,19 +585,9 @@ instance FromJSON EmailType where
|
||||
_ -> EmailType t
|
||||
|
||||
allPersonInfo :: A.Value -> [(Text, Text)]
|
||||
allPersonInfo (A.Object o) = map enc $ mapToList o
|
||||
where
|
||||
enc (key, A.String s) = (keyToText key, s)
|
||||
enc (key, v) = (keyToText key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
|
||||
|
||||
#if MIN_VERSION_aeson(2, 0, 0)
|
||||
keyToText = Data.Aeson.Key.toText
|
||||
mapToList = Data.Aeson.KeyMap.toList
|
||||
#else
|
||||
keyToText = id
|
||||
mapToList = M.toList
|
||||
#endif
|
||||
|
||||
allPersonInfo (A.Object o) = map enc $ M.toList o
|
||||
where enc (key, A.String s) = (key, s)
|
||||
enc (key, v) = (key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
|
||||
allPersonInfo _ = []
|
||||
|
||||
|
||||
|
||||
@ -131,9 +131,10 @@ module Yesod.Auth.Hardcoded
|
||||
, loginR )
|
||||
where
|
||||
|
||||
import Yesod.Auth (AuthHandler, AuthPlugin (..), AuthRoute,
|
||||
import Yesod.Auth (AuthPlugin (..), AuthRoute,
|
||||
Creds (..), Route (..), YesodAuth,
|
||||
loginErrorMessageI, setCredsRedirect)
|
||||
loginErrorMessageI, setCredsRedirect,
|
||||
AuthHandler)
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
import Yesod.Core
|
||||
import Yesod.Form (ireq, runInputPost, textField)
|
||||
@ -158,9 +159,8 @@ authHardcoded :: YesodAuthHardcoded m => AuthPlugin m
|
||||
authHardcoded =
|
||||
AuthPlugin "hardcoded" dispatch loginWidget
|
||||
where
|
||||
dispatch :: YesodAuthHardcoded m => Text -> [Text] -> AuthHandler m TypedContent
|
||||
dispatch "POST" ["login"] = postLoginR >>= sendResponse
|
||||
dispatch _ _ = notFound
|
||||
dispatch _ _ = notFound
|
||||
loginWidget toMaster = do
|
||||
request <- getRequest
|
||||
[whamlet|
|
||||
|
||||
@ -282,13 +282,13 @@ germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"
|
||||
germanMessage LoginOpenID = "Login via OpenID"
|
||||
germanMessage LoginGoogle = "Login via Google"
|
||||
germanMessage LoginYahoo = "Login via Yahoo"
|
||||
germanMessage Email = "E-Mail"
|
||||
germanMessage UserName = "Benutzername"
|
||||
germanMessage Email = "Email"
|
||||
germanMessage UserName = "Benutzername" -- FIXME by Google Translate "user name"
|
||||
germanMessage Password = "Passwort"
|
||||
germanMessage CurrentPassword = "Aktuelles Passwort"
|
||||
germanMessage Register = "Registrieren"
|
||||
germanMessage RegisterLong = "Neuen Account registrieren"
|
||||
germanMessage EnterEmail = "Bitte die E-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."
|
||||
germanMessage EnterEmail = "Bitte die e-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."
|
||||
germanMessage ConfirmationEmailSentTitle = "Bestätigung verschickt."
|
||||
germanMessage (ConfirmationEmailSent email) =
|
||||
"Eine Bestätigung wurde an " `mappend`
|
||||
@ -308,23 +308,24 @@ germanMessage ConfirmPass = "Bestätigen"
|
||||
germanMessage PassMismatch = "Die Passwörter stimmen nicht überein"
|
||||
germanMessage PassUpdated = "Passwort überschrieben"
|
||||
germanMessage Facebook = "Login über Facebook"
|
||||
germanMessage LoginViaEmail = "Login via E-Mail"
|
||||
germanMessage LoginViaEmail = "Login via e-Mail"
|
||||
germanMessage InvalidLogin = "Ungültiger Login"
|
||||
germanMessage NowLoggedIn = "Login erfolgreich"
|
||||
germanMessage LoginTitle = "Anmelden"
|
||||
germanMessage LoginTitle = "Log In"
|
||||
germanMessage PleaseProvideUsername = "Bitte Nutzername angeben"
|
||||
germanMessage PleaseProvidePassword = "Bitte Passwort angeben"
|
||||
germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben"
|
||||
germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter"
|
||||
germanMessage NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben"
|
||||
germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter"
|
||||
germanMessage PasswordResetTitle = "Passwort zurücksetzen"
|
||||
germanMessage ProvideIdentifier = "E-Mail-Adresse oder Nutzername"
|
||||
germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen"
|
||||
germanMessage PasswordResetPrompt = "Nach Einhabe der E-Mail-Adresse oder des Nutzernamen wird eine E-Mail zugesendet mit welcher das Passwort zurückgesetzt werden kann."
|
||||
germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"
|
||||
germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen"
|
||||
germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann."
|
||||
germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"
|
||||
germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO
|
||||
germanMessage Logout = "Abmelden"
|
||||
germanMessage LogoutTitle = "Abmelden"
|
||||
germanMessage AuthError = "Fehler beim Anmelden"
|
||||
-- TODO
|
||||
germanMessage i@(IdentifierNotFound _) = englishMessage i
|
||||
germanMessage Logout = "Ausloggen" -- FIXME by Google Translate
|
||||
germanMessage LogoutTitle = "Ausloggen" -- FIXME by Google Translate
|
||||
germanMessage AuthError = "Autorisierungsfehler" -- FIXME by Google Translate
|
||||
|
||||
frenchMessage :: AuthMessage -> Text
|
||||
frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"
|
||||
|
||||
@ -1,6 +1,5 @@
|
||||
cabal-version: >=1.10
|
||||
name: yesod-auth
|
||||
version: 1.6.11.2
|
||||
version: 1.6.10
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman, Patrick Brisbin
|
||||
@ -8,6 +7,7 @@ maintainer: Michael Snoyman <michael@snoyman.com>
|
||||
synopsis: Authentication for Yesod.
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.6.0
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-auth>
|
||||
@ -20,10 +20,8 @@ flag network-uri
|
||||
default: True
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
build-depends: base >= 4.10 && < 5
|
||||
, aeson >= 0.7
|
||||
, attoparsec-aeson >= 2.1
|
||||
, authenticate >= 1.3.4
|
||||
, base16-bytestring
|
||||
, base64-bytestring
|
||||
@ -45,7 +43,7 @@ library
|
||||
, http-types
|
||||
, memory
|
||||
, nonce >= 1.0.2 && < 1.1
|
||||
, persistent >= 2.8
|
||||
, persistent >= 2.8 && < 2.11
|
||||
, random >= 1.0.0.2
|
||||
, safe
|
||||
, shakespeare
|
||||
@ -58,7 +56,7 @@ library
|
||||
, unordered-containers
|
||||
, wai >= 1.4
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, yesod-form >= 1.6 && < 1.8
|
||||
, yesod-form >= 1.6 && < 1.7
|
||||
, yesod-persistent >= 1.6
|
||||
|
||||
if flag(network-uri)
|
||||
|
||||
@ -9,18 +9,13 @@ import Data.List (isPrefixOf, isSuffixOf, stripPrefix)
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as TIO
|
||||
#if MIN_VERSION_Cabal(3, 7, 0)
|
||||
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
|
||||
#elif MIN_VERSION_Cabal(2, 2, 0)
|
||||
#if MIN_VERSION_Cabal(2, 2, 0)
|
||||
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
|
||||
#elif MIN_VERSION_Cabal(2, 0, 0)
|
||||
import Distribution.PackageDescription.Parse (readGenericPackageDescription)
|
||||
#else
|
||||
import Distribution.PackageDescription.Parse (readPackageDescription)
|
||||
#endif
|
||||
#if MIN_VERSION_Cabal(3, 6, 0)
|
||||
import Distribution.Utils.Path
|
||||
#endif
|
||||
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
|
||||
import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)
|
||||
import Distribution.Verbosity (normal)
|
||||
@ -67,18 +62,18 @@ addHandlerInteractive :: IO ()
|
||||
addHandlerInteractive = do
|
||||
cabal <- getCabal
|
||||
let routeInput = do
|
||||
putStr "Name of route (without trailing R): "
|
||||
hFlush stdout
|
||||
name <- getLine
|
||||
checked <- checkRoute name cabal
|
||||
case checked of
|
||||
Left err@EmptyRoute -> (error . show) err
|
||||
Left err@RouteCaseError -> print err >> routeInput
|
||||
Left err@(RouteExists _) -> do
|
||||
print err
|
||||
putStrLn "Try another name or leave blank to exit"
|
||||
routeInput
|
||||
Right p -> return p
|
||||
putStr "Name of route (without trailing R): "
|
||||
hFlush stdout
|
||||
name <- getLine
|
||||
checked <- checkRoute name cabal
|
||||
case checked of
|
||||
Left err@EmptyRoute -> (error . show) err
|
||||
Left err@RouteCaseError -> print err >> routeInput
|
||||
Left err@(RouteExists _) -> do
|
||||
print err
|
||||
putStrLn "Try another name or leave blank to exit"
|
||||
routeInput
|
||||
Right p -> return p
|
||||
|
||||
routePair <- routeInput
|
||||
putStr "Enter route pattern (ex: /entry/#EntryId): "
|
||||
@ -89,22 +84,13 @@ addHandlerInteractive = do
|
||||
methods <- getLine
|
||||
addHandlerFiles cabal routePair pattern methods
|
||||
|
||||
getRoutesFilePath :: IO FilePath
|
||||
getRoutesFilePath = do
|
||||
let oldPath = "config/routes"
|
||||
oldExists <- doesFileExist oldPath
|
||||
pure $ if oldExists
|
||||
then oldPath
|
||||
else "config/routes.yesodroutes"
|
||||
|
||||
addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO ()
|
||||
addHandlerFiles cabal (name, handlerFile) pattern methods = do
|
||||
src <- getSrcDir cabal
|
||||
let applicationFile = concat [src, "/Application.hs"]
|
||||
modify applicationFile $ fixApp name
|
||||
modify cabal $ fixCabal name
|
||||
routesPath <- getRoutesFilePath
|
||||
modify routesPath $ fixRoutes name pattern methods
|
||||
modify "config/routes" $ fixRoutes name pattern methods
|
||||
writeFile handlerFile $ mkHandler name pattern methods
|
||||
specExists <- doesFileExist specFile
|
||||
unless specExists $
|
||||
@ -252,8 +238,4 @@ getSrcDir cabal = do
|
||||
#endif
|
||||
let buildInfo = allBuildInfo pd
|
||||
srcDirs = concatMap hsSourceDirs buildInfo
|
||||
#if MIN_VERSION_Cabal(3, 6, 0)
|
||||
return $ maybe "." getSymbolicPath $ listToMaybe srcDirs
|
||||
#else
|
||||
return $ fromMaybe "." $ listToMaybe srcDirs
|
||||
#endif
|
||||
|
||||
@ -1,29 +1,3 @@
|
||||
# ChangeLog for yesod-bin
|
||||
|
||||
## 1.6.2.2
|
||||
|
||||
* Support Cabal 3.8 [#1769](https://github.com/yesodweb/yesod/pull/1769)
|
||||
|
||||
## 1.6.2.1
|
||||
|
||||
* Support Cabal 3.6 [#1754](https://github.com/yesodweb/yesod/pull/1754)
|
||||
|
||||
## 1.6.2
|
||||
|
||||
* aeson 2.0
|
||||
|
||||
## 1.6.1
|
||||
|
||||
Added command line options `cert` and `key` to allow TLS certificate and key files to be passed to `yesod devel` [#1717](https://github.com/yesodweb/yesod/pull/1717)
|
||||
|
||||
## 1.6.0.6
|
||||
|
||||
Fix the `add-handler` subcommand to support both the old default routes filename (`routes`) and the new one (`routes.yesodroutes`) [#1688](https://github.com/yesodweb/yesod/pull/1688)
|
||||
|
||||
## 1.6.0.5
|
||||
|
||||
* Use process groups to ensure GHC is killed on Ctrl-C [#1683](https://github.com/yesodweb/yesod/pull/1683)
|
||||
|
||||
## 1.6.0.4
|
||||
|
||||
* Support Cabal 3.0
|
||||
|
||||
@ -28,9 +28,6 @@ import Data.String (fromString)
|
||||
import Data.Time (getCurrentTime)
|
||||
import qualified Distribution.Package as D
|
||||
import qualified Distribution.PackageDescription as D
|
||||
#if MIN_VERSION_Cabal(3,8,0)
|
||||
import qualified Distribution.Simple.PackageDescription as D
|
||||
#endif
|
||||
#if MIN_VERSION_Cabal(2, 2, 0)
|
||||
import qualified Distribution.PackageDescription.Parsec as D
|
||||
#else
|
||||
@ -59,7 +56,7 @@ import Network.Wai (requestHeaderHost,
|
||||
responseLBS)
|
||||
import Network.Wai.Handler.Warp (defaultSettings, runSettings,
|
||||
setPort, setHost)
|
||||
import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings,
|
||||
import Network.Wai.Handler.WarpTLS (runTLS,
|
||||
tlsSettingsMemory)
|
||||
import Network.Wai.Parse (parseHttpAccept)
|
||||
import Say
|
||||
@ -129,7 +126,6 @@ data DevelOpts = DevelOpts
|
||||
, proxyTimeout :: Int
|
||||
, useReverseProxy :: Bool
|
||||
, develHost :: Maybe String
|
||||
, cert :: Maybe (FilePath, FilePath)
|
||||
} deriving (Show, Eq)
|
||||
|
||||
-- | Run a reverse proxy from the develPort and develTlsPort ports to
|
||||
@ -139,7 +135,7 @@ reverseProxy :: DevelOpts -> TVar Int -> IO ()
|
||||
reverseProxy opts appPortVar = do
|
||||
manager <- newManager $ managerSetProxy noProxy tlsManagerSettings
|
||||
let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")]
|
||||
sayV = when (verbose opts) . sayString
|
||||
sayV = when (verbose opts) . sayString
|
||||
let onExc _ req
|
||||
| maybe False (("application/json" `elem`) . parseHttpAccept)
|
||||
(lookup "accept" $ requestHeaders req) =
|
||||
@ -174,12 +170,10 @@ reverseProxy opts appPortVar = do
|
||||
manager
|
||||
defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings
|
||||
runProxyTls port app = do
|
||||
let certDef = $(embedFile "certificate.pem")
|
||||
keyDef = $(embedFile "key.pem")
|
||||
theSettings = case cert opts of
|
||||
Nothing -> tlsSettingsMemory certDef keyDef
|
||||
Just (c,k) -> tlsSettings c k
|
||||
runTLS theSettings (setPort port defaultSettings') $ \req send -> do
|
||||
let cert = $(embedFile "certificate.pem")
|
||||
key = $(embedFile "key.pem")
|
||||
tlsSettings = tlsSettingsMemory cert key
|
||||
runTLS tlsSettings (setPort port defaultSettings') $ \req send -> do
|
||||
let req' = req
|
||||
{ requestHeaders
|
||||
= ("X-Forwarded-Proto", "https")
|
||||
@ -351,8 +345,7 @@ devel opts passThroughArgs = do
|
||||
myPath <- getExecutablePath
|
||||
let procConfig = setStdout createSource
|
||||
$ setStderr createSource
|
||||
$ setCreateGroup True -- because need when yesod-bin killed and kill child ghc
|
||||
$ proc "stack" $
|
||||
$ setDelegateCtlc True $ proc "stack" $
|
||||
[ "build"
|
||||
, "--fast"
|
||||
, "--file-watch"
|
||||
|
||||
@ -1,16 +1,10 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Keter
|
||||
( keter
|
||||
) where
|
||||
|
||||
import Data.Yaml
|
||||
|
||||
#if MIN_VERSION_aeson(2, 0, 0)
|
||||
import qualified Data.Aeson.KeyMap as Map
|
||||
#else
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Exit
|
||||
|
||||
@ -83,7 +83,6 @@ Now some weird notes:
|
||||
`yesod devel` also writes to a file
|
||||
`yesod-devel/devel-terminate`. Your devel script should respect this
|
||||
file and shutdown whenever it exists.
|
||||
(It may be fixed in 1.6.0.5.)
|
||||
* If your .cabal file defines them, `yesod devel` will tell Stack to
|
||||
build with the flags `dev` and `library-only`. You can use this to
|
||||
speed up compile times (biggest win: skip building executables, thus
|
||||
|
||||
@ -30,13 +30,12 @@ data Command = Init [String]
|
||||
| Build { buildExtraArgs :: [String] }
|
||||
| Touch
|
||||
| Devel { develSuccessHook :: Maybe String
|
||||
, develExtraArgs :: [String]
|
||||
, develExtraArgs :: [String]
|
||||
, develPort :: Int
|
||||
, develTlsPort :: Int
|
||||
, proxyTimeout :: Int
|
||||
, noReverseProxy :: Bool
|
||||
, develHost :: Maybe String
|
||||
, cert :: Maybe (FilePath, FilePath)
|
||||
}
|
||||
| DevelSignal
|
||||
| Test
|
||||
@ -91,7 +90,6 @@ main = do
|
||||
, proxyTimeout = proxyTimeout
|
||||
, useReverseProxy = not noReverseProxy
|
||||
, develHost = develHost
|
||||
, cert = cert
|
||||
} develExtraArgs
|
||||
DevelSignal -> develSignal
|
||||
where
|
||||
@ -169,11 +167,6 @@ develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "C
|
||||
<> help "Disable reverse proxy" )
|
||||
<*> optStr (long "host" <> metavar "HOST"
|
||||
<> help "Host interface to bind to; IP address, '*' for all interfaces, '*4' for IP4, '*6' for IP6")
|
||||
<*> optional ( (,)
|
||||
<$> strOption (long "cert" <> metavar "CERT"
|
||||
<> help "Path to TLS certificate file, requires that --key is also defined")
|
||||
<*> strOption (long "key" <> metavar "KEY"
|
||||
<> help "Path to TLS key file, requires that --cert is also defined") )
|
||||
|
||||
extraStackArgs :: Parser [String]
|
||||
extraStackArgs = many (strOption ( long "extra-stack-arg" <> short 'e' <> metavar "ARG"
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-bin
|
||||
version: 1.6.2.2
|
||||
version: 1.6.0.4
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -8,7 +8,7 @@ synopsis: The yesod helper executable.
|
||||
description: See README.md for more information
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.10
|
||||
cabal-version: >= 1.6
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
|
||||
@ -19,7 +19,6 @@ extra-source-files:
|
||||
*.pem
|
||||
|
||||
executable yesod
|
||||
default-language: Haskell2010
|
||||
if os(windows)
|
||||
cpp-options: -DWINDOWS
|
||||
if os(openbsd)
|
||||
@ -35,7 +34,7 @@ executable yesod
|
||||
, directory >= 1.2.1
|
||||
, file-embed
|
||||
, filepath >= 1.1
|
||||
, fsnotify
|
||||
, fsnotify >= 0.0 && < 0.4
|
||||
, http-client >= 0.4.7
|
||||
, http-client-tls
|
||||
, http-reverse-proxy >= 0.4
|
||||
@ -61,7 +60,6 @@ executable yesod
|
||||
, warp-tls >= 3.0.1
|
||||
, yaml >= 0.8 && < 0.12
|
||||
, zlib >= 0.5
|
||||
, aeson
|
||||
|
||||
ghc-options: -Wall -threaded -rtsopts
|
||||
main-is: main.hs
|
||||
|
||||
@ -1,122 +1,5 @@
|
||||
# ChangeLog for yesod-core
|
||||
|
||||
## 1.6.25.1
|
||||
|
||||
* Export the options that were created in 1.6.25.0 [#1825](https://github.com/yesodweb/yesod/pull/1825)
|
||||
|
||||
## 1.6.25.0
|
||||
|
||||
* Add an options structure that allows the user to set which instances will be derived for a routes structure. [#1819](https://github.com/yesodweb/yesod/pull/1819)
|
||||
|
||||
## 1.6.24.5
|
||||
|
||||
* Support Aeson 2.2 [#1818](https://github.com/yesodweb/yesod/pull/1818)
|
||||
|
||||
## 1.6.24.4
|
||||
|
||||
* Fix test-suite compilation error for GHC >= 9.0.1 [#1812](https://github.com/yesodweb/yesod/pull/1812)
|
||||
|
||||
## 1.6.24.3
|
||||
|
||||
* Fix subsite-to-subsite dispatch [#1805](https://github.com/yesodweb/yesod/pull/1805)
|
||||
|
||||
## 1.6.24.2
|
||||
|
||||
* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
|
||||
|
||||
## 1.6.24.1
|
||||
|
||||
* Adapt to removal of `ListT` from transformers-0.6. [#1796](https://github.com/yesodweb/yesod/pull/1796)
|
||||
|
||||
## 1.6.24.0
|
||||
|
||||
* Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772).
|
||||
|
||||
## 1.6.23.1
|
||||
|
||||
* Fix typo in creation of the description `<meta>` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766)
|
||||
|
||||
## 1.6.23
|
||||
|
||||
* Add idempotent versions of `setDescription`, `setDescriptionI`. These functions
|
||||
have odd behaviour when called multiple times, so they are now warned against.
|
||||
This can't be a silent change - if you want to switch to the new functions, make
|
||||
sure your layouts are updated to use `pageDescription` as well as `pageTitle`.
|
||||
[#1765](https://github.com/yesodweb/yesod/pull/1765)
|
||||
|
||||
## 1.6.22.1
|
||||
|
||||
+ Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756)
|
||||
|
||||
## 1.6.22.0
|
||||
|
||||
* Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745)
|
||||
* Add instances for `ToContent Void`, `ToTypedContent Void`. [#1752](https://github.com/yesodweb/yesod/pull/1752)
|
||||
* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753)
|
||||
* Support template-haskell 2.18 [#1754](https://github.com/yesodweb/yesod/pull/1754)
|
||||
|
||||
## 1.6.21.0
|
||||
|
||||
* Export `Yesod.Core.Dispatch.defaultGen` so that users may reuse it for their own `YesodRunnerEnv`s [#1734](https://github.com/yesodweb/yesod/pull/1734)
|
||||
|
||||
## 1.6.20.2
|
||||
|
||||
* Fix compatibility with template-haskell 2.17 [#1729](https://github.com/yesodweb/yesod/pull/1729)
|
||||
|
||||
## 1.6.20.1
|
||||
|
||||
* Throw an error in `breadcrumbs` if the trail of breadcrumbs is circular. [#1727](https://github.com/yesodweb/yesod/issues/1727)
|
||||
|
||||
## 1.6.20
|
||||
|
||||
* Generate CSRF tokens using a secure entropy source [#1726](https://github.com/yesodweb/yesod/pull/1726)
|
||||
* Change semantics of `yreGen` and `defaultGen`
|
||||
|
||||
## 1.6.19.0
|
||||
|
||||
* Change order of priority in `languages`[#1721](https://github.com/yesodweb/yesod/pull/1721)
|
||||
|
||||
## 1.6.18.8
|
||||
|
||||
* Fix test suite for wai-extra change around vary header
|
||||
|
||||
## 1.6.18.7
|
||||
|
||||
* Fix functions generating Open Graph metadata[#1709](https://github.com/yesodweb/yesod/pull/1709)
|
||||
|
||||
## 1.6.18.6
|
||||
|
||||
* Update documentation from `HandlerT` to `HandlerFor` [#1703](https://github.com/yesodweb/yesod/pull/1703)
|
||||
|
||||
## 1.6.18.5
|
||||
|
||||
Document `ErrorResponse` [#1698](https://github.com/yesodweb/yesod/pull/1698)
|
||||
|
||||
## 1.6.18.4
|
||||
|
||||
* Fixed a bug where `mkYesod` and other TH functions didn't work for datatypes with explicitly stated type variables, including the case with typeclass constraints. [https://github.com/yesodweb/yesod/pull/1697](#1697)
|
||||
|
||||
## 1.6.18.3
|
||||
|
||||
* Remove mention of an oudated Yesod type (`GHandler`) from the docs for `handlerToIO`. [https://github.com/yesodweb/yesod/pull/1695](#1695)
|
||||
|
||||
## 1.6.18.2
|
||||
|
||||
* Recommends `.yesodroutes` as the file extension for Yesod routes files. [#1686](https://github.com/yesodweb/yesod/pull/1686)
|
||||
|
||||
## 1.6.18.1
|
||||
|
||||
* Increase the size of CSRF token
|
||||
|
||||
## 1.6.18
|
||||
|
||||
* Add functions for setting description and OG meta [#1663](https://github.com/yesodweb/yesod/pull/1663)
|
||||
|
||||
* Use `DeriveLift` to implement the `Lift` instances for `ResourceTree`,
|
||||
`Resource`, `Piece`, and `Dispatch`. Among other benefits, this provides
|
||||
implementations of `liftTyped` on `template-haskell-2.16` (GHC 8.10) or
|
||||
later. [#1664](https://github.com/yesodweb/yesod/pull/1664)
|
||||
|
||||
## 1.6.17.3
|
||||
|
||||
* Support for `unliftio-core` 0.2
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Core.Class.Breadcrumbs where
|
||||
|
||||
import Yesod.Core.Handler
|
||||
@ -16,7 +15,7 @@ class YesodBreadcrumbs site where
|
||||
|
||||
-- | Gets the title of the current page and the hierarchy of parent pages,
|
||||
-- along with their respective titles.
|
||||
breadcrumbs :: (YesodBreadcrumbs site, Show (Route site), Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)])
|
||||
breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)])
|
||||
breadcrumbs = do
|
||||
x <- getCurrentRoute
|
||||
case x of
|
||||
@ -27,8 +26,6 @@ breadcrumbs = do
|
||||
return (title, z)
|
||||
where
|
||||
go back Nothing = return back
|
||||
go back (Just this)
|
||||
| this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this
|
||||
| otherwise = do
|
||||
(title, next) <- breadcrumb this
|
||||
go ((this, title) : back) next
|
||||
go back (Just this) = do
|
||||
(title, next) <- breadcrumb this
|
||||
go ((this, title) : back) next
|
||||
|
||||
@ -19,9 +19,7 @@ import Control.Monad.Trans.Class (lift)
|
||||
import Data.Conduit.Internal (Pipe, ConduitM)
|
||||
|
||||
import Control.Monad.Trans.Identity ( IdentityT)
|
||||
#if !MIN_VERSION_transformers(0,6,0)
|
||||
import Control.Monad.Trans.List ( ListT )
|
||||
#endif
|
||||
import Control.Monad.Trans.Maybe ( MaybeT )
|
||||
import Control.Monad.Trans.Except ( ExceptT )
|
||||
import Control.Monad.Trans.Reader ( ReaderT )
|
||||
@ -78,9 +76,7 @@ instance MonadHandler (WidgetFor site) where
|
||||
#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
|
||||
#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
|
||||
GO(IdentityT)
|
||||
#if !MIN_VERSION_transformers(0,6,0)
|
||||
GO(ListT)
|
||||
#endif
|
||||
GO(MaybeT)
|
||||
GO(ExceptT e)
|
||||
GO(ReaderT r)
|
||||
@ -108,9 +104,7 @@ liftWidgetT = liftWidget
|
||||
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget
|
||||
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget
|
||||
GO(IdentityT)
|
||||
#if !MIN_VERSION_transformers(0,6,0)
|
||||
GO(ListT)
|
||||
#endif
|
||||
GO(MaybeT)
|
||||
GO(ExceptT e)
|
||||
GO(ReaderT r)
|
||||
|
||||
@ -1,9 +1,7 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Core.Class.Yesod where
|
||||
|
||||
import Yesod.Core.Content
|
||||
@ -54,10 +52,8 @@ import Yesod.Core.Types
|
||||
import Yesod.Core.Internal.Session
|
||||
import Yesod.Core.Widget
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
import qualified Network.Wai.Request
|
||||
import Data.IORef
|
||||
import UnliftIO (SomeException, catch, MonadUnliftIO)
|
||||
|
||||
-- | Define settings for a Yesod applications. All methods have intelligent
|
||||
-- defaults, and therefore no implementation is required.
|
||||
@ -74,16 +70,6 @@ class RenderRoute site => Yesod site where
|
||||
approot :: Approot site
|
||||
approot = guessApproot
|
||||
|
||||
-- | @since 1.6.24.0
|
||||
-- allows the user to specify how exceptions are cought.
|
||||
-- by default all async exceptions are thrown and synchronous
|
||||
-- exceptions render a 500 page.
|
||||
-- To catch all exceptions (even async) to render a 500 page,
|
||||
-- set this to 'UnliftIO.Exception.catchSyncOrAsync'. Beware
|
||||
-- this may have negative effects with functions like 'timeout'.
|
||||
catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a
|
||||
catchHandlerExceptions _ = catch
|
||||
|
||||
-- | Output error response pages.
|
||||
--
|
||||
-- Default value: 'defaultErrorHandler'.
|
||||
@ -101,8 +87,6 @@ class RenderRoute site => Yesod site where
|
||||
<html>
|
||||
<head>
|
||||
<title>#{pageTitle p}
|
||||
$maybe description <- pageDescription p
|
||||
<meta name="description" content="#{description}">
|
||||
^{pageHead p}
|
||||
<body>
|
||||
$forall (status, msg) <- msgs
|
||||
@ -547,17 +531,16 @@ widgetToPageContent :: Yesod site
|
||||
=> WidgetFor site ()
|
||||
-> HandlerFor site (PageContent (Route site))
|
||||
widgetToPageContent w = do
|
||||
jsAttrs <- jsAttributesHandler
|
||||
HandlerFor $ \hd -> do
|
||||
jsAttrs <- jsAttributesHandler
|
||||
HandlerFor $ \hd -> do
|
||||
master <- unHandlerFor getYesod hd
|
||||
ref <- newIORef mempty
|
||||
unWidgetFor w WidgetData
|
||||
{ wdRef = ref
|
||||
, wdHandler = hd
|
||||
}
|
||||
GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref
|
||||
GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref
|
||||
let title = maybe mempty unTitle mTitle
|
||||
description = unDescription <$> mDescription
|
||||
scripts = runUniqueList scripts'
|
||||
stylesheets = runUniqueList stylesheets'
|
||||
|
||||
@ -627,7 +610,7 @@ widgetToPageContent w = do
|
||||
^{regularScriptLoad}
|
||||
|]
|
||||
|
||||
return $ PageContent title description headAll $
|
||||
return $ PageContent title headAll $
|
||||
case jsLoader master of
|
||||
BottomOfBody -> bodyScript
|
||||
_ -> body
|
||||
|
||||
@ -64,7 +64,6 @@ import qualified Data.Conduit.Internal as CI
|
||||
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Text.Lazy.Builder (toLazyText)
|
||||
import Data.Void (Void, absurd)
|
||||
import Yesod.Core.Types
|
||||
import Text.Lucius (Css, renderCss)
|
||||
import Text.Julius (Javascript, unJavascript)
|
||||
@ -104,8 +103,6 @@ instance ToContent Html where
|
||||
toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
|
||||
instance ToContent () where
|
||||
toContent () = toContent B.empty
|
||||
instance ToContent Void where
|
||||
toContent = absurd
|
||||
instance ToContent (ContentType, Content) where
|
||||
toContent = snd
|
||||
instance ToContent TypedContent where
|
||||
@ -279,8 +276,6 @@ instance ToTypedContent TypedContent where
|
||||
toTypedContent = id
|
||||
instance ToTypedContent () where
|
||||
toTypedContent () = TypedContent typePlain (toContent ())
|
||||
instance ToTypedContent Void where
|
||||
toTypedContent = absurd
|
||||
instance ToTypedContent (ContentType, Content) where
|
||||
toTypedContent (ct, content) = TypedContent ct content
|
||||
instance ToTypedContent RepJson where
|
||||
|
||||
@ -10,24 +10,13 @@ module Yesod.Core.Dispatch
|
||||
, parseRoutesFile
|
||||
, parseRoutesFileNoCheck
|
||||
, mkYesod
|
||||
, mkYesodOpts
|
||||
, mkYesodWith
|
||||
-- ** More fine-grained
|
||||
, mkYesodData
|
||||
, mkYesodDataOpts
|
||||
, mkYesodSubData
|
||||
, mkYesodSubDataOpts
|
||||
, mkYesodDispatch
|
||||
, mkYesodDispatchOpts
|
||||
, mkYesodSubDispatch
|
||||
-- *** Route generation options
|
||||
, RouteOpts
|
||||
, defaultOpts
|
||||
, setEqDerived
|
||||
, setShowDerived
|
||||
, setReadDerived
|
||||
-- *** Helpers
|
||||
, defaultGen
|
||||
, getGetMaxExpires
|
||||
-- ** Path pieces
|
||||
, PathPiece (..)
|
||||
@ -57,7 +46,6 @@ import qualified Network.Wai as W
|
||||
|
||||
import Data.ByteString.Lazy.Char8 ()
|
||||
|
||||
import Data.Bits ((.|.), finiteBitSize, shiftL)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
@ -71,7 +59,7 @@ import Yesod.Core.Class.Dispatch
|
||||
import Yesod.Core.Internal.Run
|
||||
import Text.Read (readMaybe)
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Entropy (getEntropy)
|
||||
import qualified System.Random as Random
|
||||
import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
|
||||
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
|
||||
|
||||
@ -104,21 +92,8 @@ toWaiAppPlain site = do
|
||||
, yreGetMaxExpires = getMaxExpires
|
||||
}
|
||||
|
||||
-- | Generate a random number uniformly distributed in the full range
|
||||
-- of 'Int'.
|
||||
--
|
||||
-- Note: Before 1.6.20, this generates pseudo-random number in an
|
||||
-- unspecified range. The range size may not be a power of 2. Since
|
||||
-- 1.6.20, this uses a secure entropy source and generates in the full
|
||||
-- range of 'Int'.
|
||||
--
|
||||
-- @since 1.6.21.0
|
||||
defaultGen :: IO Int
|
||||
defaultGen = bsToInt <$> getEntropy bytes
|
||||
where
|
||||
bits = finiteBitSize (undefined :: Int)
|
||||
bytes = div (bits + 7) 8
|
||||
bsToInt = S.foldl' (\v i -> shiftL v 8 .|. fromIntegral i) 0
|
||||
defaultGen = Random.getStdRandom Random.next
|
||||
|
||||
-- | Pure low level function to construct WAI application. Usefull
|
||||
-- when you need not standard way to run your app, or want to embed it
|
||||
@ -197,16 +172,6 @@ toWaiAppLogger logger site = do
|
||||
-- middlewares. This set may change at any point without a breaking version
|
||||
-- number. Currently, it includes:
|
||||
--
|
||||
-- * Logging
|
||||
--
|
||||
-- * GZIP compression
|
||||
--
|
||||
-- * Automatic HEAD method handling
|
||||
--
|
||||
-- * Request method override with the _method query string parameter
|
||||
--
|
||||
-- * Accept header override with the _accept query string parameter
|
||||
--
|
||||
-- If you need more fine-grained control of middlewares, please use 'toWaiApp'
|
||||
-- directly.
|
||||
--
|
||||
|
||||
@ -9,7 +9,6 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.Handler
|
||||
@ -245,7 +244,6 @@ import Text.Blaze.Html (preEscapedToHtml, toHtml)
|
||||
import qualified Data.IORef as I
|
||||
import Data.Maybe (listToMaybe, mapMaybe)
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Kind (Type)
|
||||
import Web.PathPieces (PathPiece(..))
|
||||
import Yesod.Core.Class.Handler
|
||||
import Yesod.Core.Types
|
||||
@ -262,7 +260,7 @@ import qualified Data.Word8 as W8
|
||||
import qualified Data.Foldable as Fold
|
||||
import Control.Monad.Logger (MonadLogger, logWarnS)
|
||||
|
||||
type HandlerT site (m :: Type -> Type) = HandlerFor site
|
||||
type HandlerT site (m :: * -> *) = HandlerFor site
|
||||
{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
|
||||
|
||||
get :: MonadHandler m => m GHState
|
||||
@ -371,10 +369,10 @@ getPostParams = do
|
||||
getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
|
||||
getCurrentRoute = rheRoute <$> askHandlerEnv
|
||||
|
||||
-- | Returns a function that runs 'HandlerFor' actions inside @IO@.
|
||||
-- | Returns a function that runs 'HandlerT' actions inside @IO@.
|
||||
--
|
||||
-- Sometimes you want to run an inner 'HandlerFor' action outside
|
||||
-- the control flow of an HTTP request (on the outer 'HandlerFor'
|
||||
-- Sometimes you want to run an inner 'HandlerT' action outside
|
||||
-- the control flow of an HTTP request (on the outer 'HandlerT'
|
||||
-- action). For example, you may want to spawn a new thread:
|
||||
--
|
||||
-- @
|
||||
@ -382,30 +380,30 @@ getCurrentRoute = rheRoute <$> askHandlerEnv
|
||||
-- getFooR = do
|
||||
-- runInnerHandler <- handlerToIO
|
||||
-- liftIO $ forkIO $ runInnerHandler $ do
|
||||
-- /Code here runs inside HandlerFor but on a new thread./
|
||||
-- /This is the inner HandlerFor./
|
||||
-- /Code here runs inside GHandler but on a new thread./
|
||||
-- /This is the inner GHandler./
|
||||
-- ...
|
||||
-- /Code here runs inside the request's control flow./
|
||||
-- /This is the outer HandlerFor./
|
||||
-- /This is the outer GHandler./
|
||||
-- ...
|
||||
-- @
|
||||
--
|
||||
-- Another use case for this function is creating a stream of
|
||||
-- server-sent events using 'HandlerFor' actions (see
|
||||
-- server-sent events using 'GHandler' actions (see
|
||||
-- @yesod-eventsource@).
|
||||
--
|
||||
-- Most of the environment from the outer 'HandlerFor' is preserved
|
||||
-- on the inner 'HandlerFor', however:
|
||||
-- Most of the environment from the outer 'GHandler' is preserved
|
||||
-- on the inner 'GHandler', however:
|
||||
--
|
||||
-- * The request body is cleared (otherwise it would be very
|
||||
-- difficult to prevent huge memory leaks).
|
||||
--
|
||||
-- * The cache is cleared (see 'cached').
|
||||
-- * The cache is cleared (see 'CacheKey').
|
||||
--
|
||||
-- Changes to the response made inside the inner 'HandlerFor' are
|
||||
-- Changes to the response made inside the inner 'GHandler' are
|
||||
-- ignored (e.g., session variables, cookies, response headers).
|
||||
-- This allows the inner 'HandlerFor' to outlive the outer
|
||||
-- 'HandlerFor' (e.g., on the @forkIO@ example above, a response
|
||||
-- This allows the inner 'GHandler' to outlive the outer
|
||||
-- 'GHandler' (e.g., on the @forkIO@ example above, a response
|
||||
-- may be sent to the client without killing the new thread).
|
||||
handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a)
|
||||
handlerToIO =
|
||||
@ -430,7 +428,7 @@ handlerToIO =
|
||||
-- xx From this point onwards, no references to oldHandlerData xx
|
||||
liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())
|
||||
|
||||
-- Return HandlerFor running function.
|
||||
-- Return GHandler running function.
|
||||
return $ \(HandlerFor f) ->
|
||||
liftIO $
|
||||
runResourceT $ withInternalState $ \resState -> do
|
||||
@ -1227,10 +1225,10 @@ cacheBySet key value = do
|
||||
-- Languages are determined based on the following (in descending order
|
||||
-- of preference):
|
||||
--
|
||||
-- * The _LANG get parameter.
|
||||
--
|
||||
-- * The _LANG user session variable.
|
||||
--
|
||||
-- * The _LANG get parameter.
|
||||
--
|
||||
-- * The _LANG cookie.
|
||||
--
|
||||
-- * Accept-Language HTTP header.
|
||||
@ -1239,12 +1237,11 @@ cacheBySet key value = do
|
||||
-- If a matching language is not found the default language will be used.
|
||||
--
|
||||
-- This is handled by parseWaiRequest (not exposed).
|
||||
--
|
||||
-- __NOTE__: Before version @1.6.19.0@, this function prioritized the session
|
||||
-- variable above all other sources.
|
||||
--
|
||||
languages :: MonadHandler m => m [Text]
|
||||
languages = reqLangs <$> getRequest
|
||||
languages = do
|
||||
mlang <- lookupSession langKey
|
||||
langs <- reqLangs <$> getRequest
|
||||
return $ maybe id (:) mlang langs
|
||||
|
||||
lookup' :: Eq a => a -> [(a, b)] -> [b]
|
||||
lookup' a = map snd . filter (\x -> a == fst x)
|
||||
@ -1466,8 +1463,8 @@ respond ct = return . TypedContent ct . toContent
|
||||
|
||||
-- | Use a @Source@ for the response body.
|
||||
--
|
||||
-- Note that, for ease of use, the underlying monad is a @HandlerFor@. This
|
||||
-- implies that you can run any @HandlerFor@ action. However, since a streaming
|
||||
-- Note that, for ease of use, the underlying monad is a @HandlerT@. This
|
||||
-- implies that you can run any @HandlerT@ action. However, since a streaming
|
||||
-- response occurs after the response headers have already been sent, some
|
||||
-- actions make no sense here. For example: short-circuit responses, setting
|
||||
-- headers, changing status codes, etc.
|
||||
@ -1478,8 +1475,8 @@ respondSource :: ContentType
|
||||
-> HandlerFor site TypedContent
|
||||
respondSource ctype src = HandlerFor $ \hd ->
|
||||
-- Note that this implementation relies on the fact that the ResourceT
|
||||
-- environment provided by the server is the same one used in HandlerFor.
|
||||
-- This is a safe assumption assuming the HandlerFor is run correctly.
|
||||
-- environment provided by the server is the same one used in HandlerT.
|
||||
-- This is a safe assumption assuming the HandlerT is run correctly.
|
||||
return $ TypedContent ctype $ ContentSource
|
||||
$ transPipe (lift . flip unHandlerFor hd) src
|
||||
|
||||
|
||||
@ -129,7 +129,7 @@ parseWaiRequest env session useToken mmaxBodySize =
|
||||
-- Already have a token, use it.
|
||||
Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs
|
||||
-- Don't have a token, get a random generator and make a new one.
|
||||
Nothing -> Right $ fmap Just . randomString 40
|
||||
Nothing -> Right $ fmap Just . randomString 10
|
||||
| otherwise = Left Nothing
|
||||
|
||||
textQueryString :: W.Request -> [(Text, Text)]
|
||||
|
||||
@ -1,28 +1,13 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Yesod.Core.Internal.Run
|
||||
( toErrorHandler
|
||||
, errFromShow
|
||||
, basicRunHandler
|
||||
, handleError
|
||||
, handleContents
|
||||
, evalFallback
|
||||
, runHandler
|
||||
, safeEh
|
||||
, runFakeHandler
|
||||
, yesodRunner
|
||||
, yesodRender
|
||||
, resolveApproot
|
||||
)
|
||||
where
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Core.Internal.Run where
|
||||
|
||||
|
||||
import qualified Control.Exception as EUnsafe
|
||||
import Yesod.Core.Internal.Response
|
||||
import Data.ByteString.Builder (toLazyByteString)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
@ -54,8 +39,6 @@ import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
|
||||
import Yesod.Routes.Class (Route, renderRoute)
|
||||
import Control.DeepSeq (($!!), NFData)
|
||||
import UnliftIO.Exception
|
||||
import UnliftIO(MonadUnliftIO, withRunInIO)
|
||||
import Data.Proxy(Proxy(..))
|
||||
|
||||
-- | Convert a synchronous exception into an ErrorResponse
|
||||
toErrorHandler :: SomeException -> IO ErrorResponse
|
||||
@ -88,7 +71,7 @@ basicRunHandler rhe handler yreq resState = do
|
||||
|
||||
-- Run the handler itself, capturing any runtime exceptions and
|
||||
-- converting them into a @HandlerContents@
|
||||
contents' <- rheCatchHandlerExceptions rhe
|
||||
contents' <- catchAny
|
||||
(do
|
||||
res <- unHandlerFor handler (hd istate)
|
||||
tc <- evaluate (toTypedContent res)
|
||||
@ -189,19 +172,16 @@ handleContents handleError' finalSession headers contents =
|
||||
-- | Evaluate the given value. If an exception is thrown, use it to
|
||||
-- replace the provided contents and then return @mempty@ in place of the
|
||||
-- evaluated value.
|
||||
--
|
||||
-- Note that this also catches async exceptions.
|
||||
evalFallback :: (Monoid w, NFData w)
|
||||
=> (forall a. IO a -> (SomeException -> IO a) -> IO a)
|
||||
-> HandlerContents
|
||||
=> HandlerContents
|
||||
-> w
|
||||
-> IO (w, HandlerContents)
|
||||
evalFallback catcher contents val = catcher
|
||||
evalFallback contents val = catchAny
|
||||
(fmap (, contents) (evaluate $!! val))
|
||||
(fmap ((mempty, ) . HCError) . toErrorHandler)
|
||||
|
||||
-- | Function used internally by Yesod in the process of converting a
|
||||
-- 'HandlerFor' into an 'Application'. Should not be needed by users.
|
||||
-- 'HandlerT' into an 'Application'. Should not be needed by users.
|
||||
runHandler :: ToTypedContent c
|
||||
=> RunHandlerEnv site site
|
||||
-> HandlerFor site c
|
||||
@ -212,8 +192,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
|
||||
|
||||
-- Evaluate the unfortunately-lazy session and headers,
|
||||
-- propagating exceptions into the contents
|
||||
(finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)
|
||||
(headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
|
||||
(finalSession, contents1) <- evalFallback contents0 (ghsSession state)
|
||||
(headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
|
||||
contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
|
||||
|
||||
-- Convert the HandlerContents into the final YesodResponse
|
||||
@ -236,27 +216,27 @@ safeEh log' er req = do
|
||||
(toContent ("Internal Server Error" :: S.ByteString))
|
||||
(reqSession req)
|
||||
|
||||
-- | Run a 'HandlerFor' completely outside of Yesod. This
|
||||
-- | Run a 'HandlerT' completely outside of Yesod. This
|
||||
-- function comes with many caveats and you shouldn't use it
|
||||
-- unless you fully understand what it's doing and how it works.
|
||||
--
|
||||
-- As of now, there's only one reason to use this function at
|
||||
-- all: in order to run unit tests of functions inside 'HandlerFor'
|
||||
-- all: in order to run unit tests of functions inside 'HandlerT'
|
||||
-- but that aren't easily testable with a full HTTP request.
|
||||
-- Even so, it's better to use @wai-test@ or @yesod-test@ instead
|
||||
-- of using this function.
|
||||
--
|
||||
-- This function will create a fake HTTP request (both @wai@'s
|
||||
-- 'Request' and @yesod@'s 'Request') and feed it to the
|
||||
-- @HandlerFor@. The only useful information the @HandlerFor@ may
|
||||
-- @HandlerT@. The only useful information the @HandlerT@ may
|
||||
-- get from the request is the session map, which you must supply
|
||||
-- as argument to @runFakeHandler@. All other fields contain
|
||||
-- fake information, which means that they can be accessed but
|
||||
-- won't have any useful information. The response of the
|
||||
-- @HandlerFor@ is completely ignored, including changes to the
|
||||
-- @HandlerT@ is completely ignored, including changes to the
|
||||
-- session, cookies or headers. We only return you the
|
||||
-- @HandlerFor@'s return value.
|
||||
runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
|
||||
-- @HandlerT@'s return value.
|
||||
runFakeHandler :: (Yesod site, MonadIO m) =>
|
||||
SessionMap
|
||||
-> (site -> Logger)
|
||||
-> site
|
||||
@ -277,7 +257,6 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
|
||||
, rheLog = messageLoggerSource site $ logger site
|
||||
, rheOnError = errHandler
|
||||
, rheMaxExpires = maxExpires
|
||||
, rheCatchHandlerExceptions = catchHandlerExceptions site
|
||||
}
|
||||
handler'
|
||||
errHandler err req = do
|
||||
@ -319,7 +298,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
|
||||
_ <- runResourceT $ yapp fakeRequest
|
||||
I.readIORef ret
|
||||
|
||||
yesodRunner :: forall res site . (ToTypedContent res, Yesod site)
|
||||
yesodRunner :: (ToTypedContent res, Yesod site)
|
||||
=> HandlerFor site res
|
||||
-> YesodRunnerEnv site
|
||||
-> Maybe (Route site)
|
||||
@ -354,7 +333,6 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
|
||||
, rheLog = log'
|
||||
, rheOnError = safeEh log'
|
||||
, rheMaxExpires = maxExpires
|
||||
, rheCatchHandlerExceptions = catchHandlerExceptions yreSite
|
||||
}
|
||||
rhe = rheSafe
|
||||
{ rheOnError = runHandler rheSafe . errorHandler
|
||||
|
||||
@ -1,48 +1,10 @@
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Yesod.Core.Internal.TH
|
||||
( mkYesod
|
||||
, mkYesodOpts
|
||||
|
||||
, mkYesodWith
|
||||
|
||||
, mkYesodData
|
||||
, mkYesodDataOpts
|
||||
|
||||
, mkYesodSubData
|
||||
, mkYesodSubDataOpts
|
||||
|
||||
, mkYesodWithParser
|
||||
, mkYesodWithParserOpts
|
||||
|
||||
, mkYesodDispatch
|
||||
, mkYesodDispatchOpts
|
||||
|
||||
, masterTypeSyns
|
||||
|
||||
, mkYesodGeneral
|
||||
, mkYesodGeneralOpts
|
||||
|
||||
, mkMDS
|
||||
, mkDispatchInstance
|
||||
|
||||
, mkYesodSubDispatch
|
||||
|
||||
, subTopDispatch
|
||||
, instanceD
|
||||
|
||||
, RouteOpts
|
||||
, defaultOpts
|
||||
, setEqDerived
|
||||
, setShowDerived
|
||||
, setReadDerived
|
||||
)
|
||||
where
|
||||
module Yesod.Core.Internal.TH where
|
||||
|
||||
import Prelude hiding (exp)
|
||||
import Yesod.Core.Handler
|
||||
@ -60,7 +22,6 @@ import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
|
||||
|
||||
import Yesod.Routes.TH
|
||||
import Yesod.Routes.Parse
|
||||
import Yesod.Core.Content (ToTypedContent (..))
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Class.Dispatch
|
||||
import Yesod.Core.Internal.Run
|
||||
@ -74,17 +35,7 @@ import Yesod.Core.Internal.Run
|
||||
mkYesod :: String -- ^ name of the argument datatype
|
||||
-> [ResourceTree String]
|
||||
-> Q [Dec]
|
||||
mkYesod = mkYesodOpts defaultOpts
|
||||
|
||||
-- | `mkYesod` but with custom options.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodOpts :: RouteOpts
|
||||
-> String
|
||||
-> [ResourceTree String]
|
||||
-> Q [Dec]
|
||||
mkYesodOpts opts name = fmap (uncurry (++)) . mkYesodWithParserOpts opts name False return
|
||||
|
||||
mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return
|
||||
|
||||
{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}
|
||||
-- | Similar to 'mkYesod', except contexts and type variables are not parsed.
|
||||
@ -97,30 +48,15 @@ mkYesodWith :: [[String]] -- ^ list of contexts
|
||||
-> Q [Dec]
|
||||
mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return
|
||||
|
||||
|
||||
-- | Sometimes, you will want to declare your routes in one file and define
|
||||
-- your handlers elsewhere. For example, this is the only way to break up a
|
||||
-- monolithic file into smaller parts. Use this function, paired with
|
||||
-- 'mkYesodDispatch', to do just that.
|
||||
mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodData = mkYesodDataOpts defaultOpts
|
||||
|
||||
-- | `mkYesodData` but with custom options.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name False return resS
|
||||
|
||||
mkYesodData name resS = fst <$> mkYesodWithParser name False return resS
|
||||
|
||||
mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodSubData = mkYesodSubDataOpts defaultOpts
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodSubDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name True return resS
|
||||
|
||||
mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS
|
||||
|
||||
-- | Parses contexts and type arguments out of name before generating TH.
|
||||
mkYesodWithParser :: String -- ^ foundation type
|
||||
@ -128,22 +64,11 @@ mkYesodWithParser :: String -- ^ foundation type
|
||||
-> (Exp -> Q Exp) -- ^ unwrap handler
|
||||
-> [ResourceTree String]
|
||||
-> Q([Dec],[Dec])
|
||||
mkYesodWithParser = mkYesodWithParserOpts defaultOpts
|
||||
|
||||
-- | Parses contexts and type arguments out of name before generating TH.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodWithParserOpts :: RouteOpts -- ^ Additional route options
|
||||
-> String -- ^ foundation type
|
||||
-> Bool -- ^ is this a subsite
|
||||
-> (Exp -> Q Exp) -- ^ unwrap handler
|
||||
-> [ResourceTree String]
|
||||
-> Q([Dec],[Dec])
|
||||
mkYesodWithParserOpts opts name isSub f resS = do
|
||||
mkYesodWithParser name isSub f resS = do
|
||||
let (name', rest, cxt) = case parse parseName "" name of
|
||||
Left err -> error $ show err
|
||||
Right a -> a
|
||||
mkYesodGeneralOpts opts cxt name' rest isSub f resS
|
||||
mkYesodGeneral cxt name' rest isSub f resS
|
||||
|
||||
where
|
||||
parseName = do
|
||||
@ -175,28 +100,19 @@ mkYesodWithParserOpts opts name isSub f resS = do
|
||||
parseContexts =
|
||||
sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
|
||||
|
||||
|
||||
-- | See 'mkYesodData'.
|
||||
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodDispatch = mkYesodDispatchOpts defaultOpts
|
||||
|
||||
-- | See 'mkYesodDataOpts'
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodDispatchOpts opts name = fmap snd . mkYesodWithParserOpts opts name False return
|
||||
|
||||
mkYesodDispatch name = fmap snd . mkYesodWithParser name False return
|
||||
|
||||
-- | Get the Handler and Widget type synonyms for the given site.
|
||||
masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself?
|
||||
masterTypeSyns vs site =
|
||||
[ TySynD (mkName "Handler") (fmap plainTV vs)
|
||||
[ TySynD (mkName "Handler") (fmap PlainTV vs)
|
||||
$ ConT ''HandlerFor `AppT` site
|
||||
, TySynD (mkName "Widget") (fmap plainTV vs)
|
||||
, TySynD (mkName "Widget") (fmap PlainTV vs)
|
||||
$ ConT ''WidgetFor `AppT` site `AppT` ConT ''()
|
||||
]
|
||||
|
||||
|
||||
mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
|
||||
-> String -- ^ foundation type
|
||||
-> [String] -- ^ arguments for the type
|
||||
@ -204,20 +120,7 @@ mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in Ren
|
||||
-> (Exp -> Q Exp) -- ^ unwrap handler
|
||||
-> [ResourceTree String]
|
||||
-> Q([Dec],[Dec])
|
||||
mkYesodGeneral = mkYesodGeneralOpts defaultOpts
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkYesodGeneralOpts :: RouteOpts -- ^ Options to adjust route creation
|
||||
-> [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
|
||||
-> String -- ^ foundation type
|
||||
-> [String] -- ^ arguments for the type
|
||||
-> Bool -- ^ is this a subsite
|
||||
-> (Exp -> Q Exp) -- ^ unwrap handler
|
||||
-> [ResourceTree String]
|
||||
-> Q([Dec],[Dec])
|
||||
mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
|
||||
mkYesodGeneral appCxt' namestr mtys isSub f resS = do
|
||||
let appCxt = fmap (\(c:rest) ->
|
||||
foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
|
||||
) appCxt'
|
||||
@ -238,14 +141,11 @@ mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
|
||||
let name = mkName namestr
|
||||
-- Generate as many variable names as the arity indicates
|
||||
vns <- replicateM (arity - length mtys) $ newName "t"
|
||||
-- types that you apply to get a concrete site name
|
||||
let argtypes = fmap nameToType mtys ++ fmap VarT vns
|
||||
-- typevars that should appear in synonym head
|
||||
let argvars = (fmap mkName . filter isTvar) mtys ++ vns
|
||||
-- Base type (site type with variables)
|
||||
let site = foldl' AppT (ConT name) argtypes
|
||||
let argtypes = fmap nameToType mtys ++ fmap VarT vns
|
||||
site = foldl' AppT (ConT name) argtypes
|
||||
res = map (fmap (parseType . dropBracket)) resS
|
||||
renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res
|
||||
renderRouteDec <- mkRenderRouteInstance appCxt site res
|
||||
routeAttrsDec <- mkRouteAttrsInstance appCxt site res
|
||||
dispatchDec <- mkDispatchInstance site appCxt f res
|
||||
parseRoute <- mkParseRouteInstance appCxt site res
|
||||
@ -260,15 +160,22 @@ mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
|
||||
, renderRouteDec
|
||||
, [routeAttrsDec]
|
||||
, resourcesDec
|
||||
, if isSub then [] else masterTypeSyns argvars site
|
||||
, if isSub then [] else masterTypeSyns vns site
|
||||
]
|
||||
return (dataDec, dispatchDec)
|
||||
|
||||
|
||||
mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
|
||||
mkMDS f rh sd = MkDispatchSettings
|
||||
mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
|
||||
mkMDS f rh = MkDispatchSettings
|
||||
{ mdsRunHandler = rh
|
||||
, mdsSubDispatcher = sd
|
||||
, mdsSubDispatcher =
|
||||
[|\parentRunner getSub toParent env -> yesodSubDispatch
|
||||
YesodSubRunnerEnv
|
||||
{ ysreParentRunner = parentRunner
|
||||
, ysreGetSub = getSub
|
||||
, ysreToParentRoute = toParent
|
||||
, ysreParentEnv = env
|
||||
}
|
||||
|]
|
||||
, mdsGetPathInfo = [|W.pathInfo|]
|
||||
, mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
|
||||
, mdsMethod = [|W.requestMethod|]
|
||||
@ -289,35 +196,15 @@ mkDispatchInstance :: Type -- ^ The master site type
|
||||
-> [ResourceTree c] -- ^ The resource
|
||||
-> DecsQ
|
||||
mkDispatchInstance master cxt f res = do
|
||||
clause' <-
|
||||
mkDispatchClause
|
||||
(mkMDS
|
||||
f
|
||||
[|yesodRunner|]
|
||||
[|\parentRunner getSub toParent env -> yesodSubDispatch
|
||||
YesodSubRunnerEnv
|
||||
{ ysreParentRunner = parentRunner
|
||||
, ysreGetSub = getSub
|
||||
, ysreToParentRoute = toParent
|
||||
, ysreParentEnv = env
|
||||
}
|
||||
|])
|
||||
res
|
||||
clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res
|
||||
let thisDispatch = FunD 'yesodDispatch [clause']
|
||||
return [instanceD cxt yDispatch [thisDispatch]]
|
||||
where
|
||||
yDispatch = ConT ''YesodDispatch `AppT` master
|
||||
|
||||
|
||||
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
|
||||
mkYesodSubDispatch res = do
|
||||
clause' <-
|
||||
mkDispatchClause
|
||||
(mkMDS
|
||||
return
|
||||
[|subHelper|]
|
||||
[|subTopDispatch|])
|
||||
res
|
||||
clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
|
||||
inner <- newName "inner"
|
||||
let innerFun = FunD inner [clause']
|
||||
helper <- newName "helper"
|
||||
@ -329,26 +216,5 @@ mkYesodSubDispatch res = do
|
||||
]
|
||||
return $ LetE [fun] (VarE helper)
|
||||
|
||||
|
||||
subTopDispatch ::
|
||||
(YesodSubDispatch sub master) =>
|
||||
(forall content. ToTypedContent content =>
|
||||
SubHandlerFor child master content ->
|
||||
YesodSubRunnerEnv child master ->
|
||||
Maybe (Route child) ->
|
||||
W.Application
|
||||
) ->
|
||||
(mid -> sub) ->
|
||||
(Route sub -> Route mid) ->
|
||||
YesodSubRunnerEnv mid master ->
|
||||
W.Application
|
||||
subTopDispatch _ getSub toParent env = yesodSubDispatch
|
||||
(YesodSubRunnerEnv
|
||||
{ ysreParentRunner = ysreParentRunner env
|
||||
, ysreGetSub = getSub . ysreGetSub env
|
||||
, ysreToParentRoute = ysreToParentRoute env . toParent
|
||||
, ysreParentEnv = ysreParentEnv env
|
||||
})
|
||||
|
||||
instanceD :: Cxt -> Type -> [Dec] -> Dec
|
||||
instanceD = InstanceD Nothing
|
||||
|
||||
@ -8,7 +8,6 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Yesod.Core.Types where
|
||||
|
||||
import Data.Aeson (ToJSON)
|
||||
@ -56,7 +55,7 @@ import Control.Monad.Reader (MonadReader (..))
|
||||
import Control.DeepSeq (NFData (rnf))
|
||||
import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
|
||||
import Control.Monad.Logger (MonadLoggerIO (..))
|
||||
import UnliftIO (MonadUnliftIO (..), SomeException)
|
||||
import UnliftIO (MonadUnliftIO (..))
|
||||
|
||||
-- Sessions
|
||||
type SessionMap = Map Text ByteString
|
||||
@ -183,11 +182,6 @@ data RunHandlerEnv child site = RunHandlerEnv
|
||||
--
|
||||
-- Since 1.2.0
|
||||
, rheMaxExpires :: !Text
|
||||
|
||||
-- | @since 1.6.24.0
|
||||
-- catch function for rendering 500 pages on exceptions.
|
||||
-- by default this is catch from unliftio (rethrows all async exceptions).
|
||||
, rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m => m a -> (SomeException -> m a) -> m a)
|
||||
}
|
||||
|
||||
data HandlerData child site = HandlerData
|
||||
@ -202,13 +196,7 @@ data YesodRunnerEnv site = YesodRunnerEnv
|
||||
, yreSite :: !site
|
||||
, yreSessionBackend :: !(Maybe SessionBackend)
|
||||
, yreGen :: !(IO Int)
|
||||
-- ^ Generate a random number uniformly distributed in the full
|
||||
-- range of 'Int'.
|
||||
--
|
||||
-- Note: Before 1.6.20, the default value generates pseudo-random
|
||||
-- number in an unspecified range. The range size may not be a power
|
||||
-- of 2. Since 1.6.20, the default value uses a secure entropy source
|
||||
-- and generates in the full range of 'Int'.
|
||||
-- ^ Generate a random number
|
||||
, yreGetMaxExpires :: !(IO Text)
|
||||
}
|
||||
|
||||
@ -243,7 +231,7 @@ data GHState = GHState
|
||||
|
||||
-- | An extension of the basic WAI 'W.Application' datatype to provide extra
|
||||
-- features needed by Yesod. Users should never need to use this directly, as
|
||||
-- the 'HandlerFor' monad and template haskell code should hide it away.
|
||||
-- the 'HandlerT' monad and template haskell code should hide it away.
|
||||
type YesodApp = YesodRequest -> ResourceT IO YesodResponse
|
||||
|
||||
-- | A generic widget, allowing specification of both the subsite and master
|
||||
@ -295,10 +283,9 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
|
||||
--
|
||||
-- > PageContent url -> HtmlUrl url
|
||||
data PageContent url = PageContent
|
||||
{ pageTitle :: !Html
|
||||
, pageDescription :: !(Maybe Text)
|
||||
, pageHead :: !(HtmlUrl url)
|
||||
, pageBody :: !(HtmlUrl url)
|
||||
{ pageTitle :: !Html
|
||||
, pageHead :: !(HtmlUrl url)
|
||||
, pageBody :: !(HtmlUrl url)
|
||||
}
|
||||
|
||||
data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
|
||||
@ -339,28 +326,11 @@ newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
|
||||
-- | Responses to indicate some form of an error occurred.
|
||||
data ErrorResponse =
|
||||
NotFound
|
||||
-- ^ The requested resource was not found.
|
||||
-- Examples of when this occurs include when an incorrect URL is used, or @yesod-persistent@'s 'get404' doesn't find a value.
|
||||
-- HTTP status: 404.
|
||||
| InternalError !Text
|
||||
-- ^ Some sort of unexpected exception.
|
||||
-- If your application uses `throwIO` or `error` to throw an exception, this is the form it would take.
|
||||
-- HTTP status: 500.
|
||||
| InvalidArgs ![Text]
|
||||
-- ^ Indicates some sort of invalid or missing argument, like a missing query parameter or malformed JSON body.
|
||||
-- Examples Yesod functions that send this include 'requireCheckJsonBody' and @Yesod.Auth.GoogleEmail2@.
|
||||
-- HTTP status: 400.
|
||||
| NotAuthenticated
|
||||
-- ^ Indicates the user is not logged in.
|
||||
-- This is thrown when 'isAuthorized' returns 'AuthenticationRequired'.
|
||||
-- HTTP code: 401.
|
||||
| PermissionDenied !Text
|
||||
-- ^ Indicates the user doesn't have permission to access the requested resource.
|
||||
-- This is thrown when 'isAuthorized' returns 'Unauthorized'.
|
||||
-- HTTP code: 403.
|
||||
| BadMethod !H.Method
|
||||
-- ^ Indicates the URL would have been valid if used with a different HTTP method (e.g. a GET was used, but only POST is handled.)
|
||||
-- HTTP code: 405.
|
||||
deriving (Show, Eq, Generic)
|
||||
instance NFData ErrorResponse
|
||||
|
||||
@ -394,7 +364,6 @@ data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :
|
||||
data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }
|
||||
deriving (Show, Eq)
|
||||
newtype Title = Title { unTitle :: Html }
|
||||
newtype Description = Description { unDescription :: Text }
|
||||
|
||||
newtype Head url = Head (HtmlUrl url)
|
||||
deriving Monoid
|
||||
@ -410,7 +379,6 @@ type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder
|
||||
data GWData a = GWData
|
||||
{ gwdBody :: !(Body a)
|
||||
, gwdTitle :: !(Last Title)
|
||||
, gwdDescription :: !(Last Description)
|
||||
, gwdScripts :: !(UniqueList (Script a))
|
||||
, gwdStylesheets :: !(UniqueList (Stylesheet a))
|
||||
, gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type
|
||||
@ -418,21 +386,20 @@ data GWData a = GWData
|
||||
, gwdHead :: !(Head a)
|
||||
}
|
||||
instance Monoid (GWData a) where
|
||||
mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty
|
||||
mempty = GWData mempty mempty mempty mempty mempty mempty mempty
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
mappend = (<>)
|
||||
#endif
|
||||
instance Semigroup (GWData a) where
|
||||
GWData a1 a2 a3 a4 a5 a6 a7 a8 <>
|
||||
GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData
|
||||
GWData a1 a2 a3 a4 a5 a6 a7 <>
|
||||
GWData b1 b2 b3 b4 b5 b6 b7 = GWData
|
||||
(mappend a1 b1)
|
||||
(mappend a2 b2)
|
||||
(mappend a3 b3)
|
||||
(mappend a4 b4)
|
||||
(mappend a5 b5)
|
||||
(unionWith mappend a6 b6)
|
||||
(unionWith mappend a5 b5)
|
||||
(mappend a6 b6)
|
||||
(mappend a7 b7)
|
||||
(mappend a8 b8)
|
||||
|
||||
data HandlerContents =
|
||||
HCContent !H.Status !TypedContent
|
||||
@ -489,7 +456,7 @@ instance MonadLogger (WidgetFor site) where
|
||||
instance MonadLoggerIO (WidgetFor site) where
|
||||
askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
|
||||
|
||||
-- Instances for HandlerFor
|
||||
-- Instances for HandlerT
|
||||
instance Applicative (HandlerFor site) where
|
||||
pure = HandlerFor . const . return
|
||||
(<*>) = ap
|
||||
|
||||
@ -8,8 +8,6 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
|
||||
-- generator, allowing you to create truly modular HTML components.
|
||||
module Yesod.Core.Widget
|
||||
@ -31,12 +29,6 @@ module Yesod.Core.Widget
|
||||
-- ** Head of page
|
||||
, setTitle
|
||||
, setTitleI
|
||||
, setDescription
|
||||
, setDescriptionI
|
||||
, setDescriptionIdemp
|
||||
, setDescriptionIdempI
|
||||
, setOGType
|
||||
, setOGImage
|
||||
-- ** CSS
|
||||
, addStylesheet
|
||||
, addStylesheetAttrs
|
||||
@ -66,7 +58,6 @@ import Yesod.Routes.Class
|
||||
import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
|
||||
import Text.Shakespeare.I18N (RenderMessage)
|
||||
import Data.Text (Text)
|
||||
import Data.Kind (Type)
|
||||
import qualified Data.Map as Map
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
|
||||
@ -80,7 +71,7 @@ import qualified Data.Text.Lazy.Builder as TB
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Class.Handler
|
||||
|
||||
type WidgetT site (m :: Type -> Type) = WidgetFor site
|
||||
type WidgetT site (m :: * -> *) = WidgetFor site
|
||||
{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
|
||||
|
||||
preEscapedLazyText :: TL.Text -> Html
|
||||
@ -90,19 +81,19 @@ class ToWidget site a where
|
||||
toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
|
||||
|
||||
instance render ~ RY site => ToWidget site (render -> Html) where
|
||||
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty mempty
|
||||
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
|
||||
instance render ~ RY site => ToWidget site (render -> Css) where
|
||||
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
|
||||
instance ToWidget site Css where
|
||||
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x
|
||||
instance render ~ RY site => ToWidget site (render -> CssBuilder) where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
|
||||
instance ToWidget site CssBuilder where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
|
||||
instance render ~ RY site => ToWidget site (render -> Javascript) where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just x) mempty
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
|
||||
instance ToWidget site Javascript where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just $ const x) mempty
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty
|
||||
instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where
|
||||
toWidget = liftWidget
|
||||
instance ToWidget site Html where
|
||||
@ -133,9 +124,9 @@ instance render ~ RY site => ToWidgetMedia site (render -> Css) where
|
||||
instance ToWidgetMedia site Css where
|
||||
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x
|
||||
instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
|
||||
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
|
||||
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
|
||||
instance ToWidgetMedia site CssBuilder where
|
||||
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
|
||||
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
|
||||
|
||||
class ToWidgetBody site a where
|
||||
toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
|
||||
@ -153,7 +144,7 @@ class ToWidgetHead site a where
|
||||
toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
|
||||
|
||||
instance render ~ RY site => ToWidgetHead site (render -> Html) where
|
||||
toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty mempty . Head
|
||||
toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
|
||||
instance render ~ RY site => ToWidgetHead site (render -> Css) where
|
||||
toWidgetHead = toWidget
|
||||
instance ToWidgetHead site Css where
|
||||
@ -169,133 +160,18 @@ instance ToWidgetHead site Javascript where
|
||||
instance ToWidgetHead site Html where
|
||||
toWidgetHead = toWidgetHead . const
|
||||
|
||||
-- | Set the page title.
|
||||
--
|
||||
-- Calling @setTitle@ or @setTitleI@ multiple times overrides previously set
|
||||
-- values.
|
||||
--
|
||||
-- SEO Notes:
|
||||
--
|
||||
-- * Title tags are the second most important on-page factor for SEO, after
|
||||
-- content
|
||||
-- * Every page should have a unique title tag
|
||||
-- * Start your title tag with your main targeted keyword
|
||||
-- * Don't stuff your keywords
|
||||
-- * Google typically shows 55-64 characters, so aim to keep your title
|
||||
-- length under 60 characters
|
||||
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
||||
-- set values.
|
||||
setTitle :: MonadWidget m => Html -> m ()
|
||||
setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty
|
||||
setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Set the localised page title.
|
||||
--
|
||||
-- n.b. See comments for @setTitle@
|
||||
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
||||
-- set values.
|
||||
setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
|
||||
setTitleI msg = do
|
||||
mr <- getMessageRender
|
||||
setTitle $ toHtml $ mr msg
|
||||
|
||||
-- | Add description meta tag to the head of the page
|
||||
--
|
||||
-- Google does not use the description tag as a ranking signal, but the
|
||||
-- contents of this tag will likely affect your click-through rate since it
|
||||
-- shows up in search results.
|
||||
--
|
||||
-- The average length of the description shown in Google's search results is
|
||||
-- about 160 characters on desktop, and about 130 characters on mobile, at time
|
||||
-- of writing.
|
||||
--
|
||||
-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
|
||||
--
|
||||
-- @since 1.6.18
|
||||
setDescription :: MonadWidget m => Text -> m ()
|
||||
setDescription description =
|
||||
toWidgetHead $ [hamlet|<meta name=description content=#{description}>|]
|
||||
|
||||
{-# WARNING setDescription
|
||||
[ "setDescription is not idempotent; we recommend setDescriptionIdemp instead"
|
||||
, "Multiple calls to setDescription will insert multiple meta tags in the page head."
|
||||
, "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \
|
||||
\may need to change your layout to include pageDescription."
|
||||
]
|
||||
#-}
|
||||
|
||||
-- | Add translated description meta tag to the head of the page
|
||||
--
|
||||
-- n.b. See comments for @setDescription@.
|
||||
--
|
||||
-- @since 1.6.18
|
||||
setDescriptionI
|
||||
:: (MonadWidget m, RenderMessage (HandlerSite m) msg)
|
||||
=> msg -> m ()
|
||||
setDescriptionI msg = do
|
||||
mr <- getMessageRender
|
||||
toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|]
|
||||
|
||||
{-# WARNING setDescriptionI
|
||||
[ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead"
|
||||
, "Multiple calls to setDescriptionI will insert multiple meta tags in the page head."
|
||||
, "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \
|
||||
\may need to change your layout to include pageDescription."
|
||||
]
|
||||
#-}
|
||||
|
||||
-- | Add description meta tag to the head of the page
|
||||
--
|
||||
-- Google does not use the description tag as a ranking signal, but the
|
||||
-- contents of this tag will likely affect your click-through rate since it
|
||||
-- shows up in search results.
|
||||
--
|
||||
-- The average length of the description shown in Google's search results is
|
||||
-- about 160 characters on desktop, and about 130 characters on mobile, at time
|
||||
-- of writing.
|
||||
--
|
||||
-- Unlike 'setDescription', this version is *idempotent* - calling it multiple
|
||||
-- times will result in only a single description meta tag in the head.
|
||||
--
|
||||
-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
|
||||
--
|
||||
-- @since 1.6.23
|
||||
setDescriptionIdemp :: MonadWidget m => Text -> m ()
|
||||
setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Add translated description meta tag to the head of the page
|
||||
--
|
||||
-- n.b. See comments for @setDescriptionIdemp@.
|
||||
--
|
||||
-- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple
|
||||
-- times will result in only a single description meta tag in the head.
|
||||
--
|
||||
-- @since 1.6.23
|
||||
setDescriptionIdempI
|
||||
:: (MonadWidget m, RenderMessage (HandlerSite m) msg)
|
||||
=> msg -> m ()
|
||||
setDescriptionIdempI msg = do
|
||||
mr <- getMessageRender
|
||||
setDescriptionIdemp $ mr msg
|
||||
|
||||
-- | Add OpenGraph type meta tag to the head of the page
|
||||
--
|
||||
-- See all available OG types here: https://ogp.me/#types
|
||||
--
|
||||
-- @since 1.6.18
|
||||
setOGType :: MonadWidget m => Text -> m ()
|
||||
setOGType a = toWidgetHead $ [hamlet|<meta property="og:type" content=#{a}>|]
|
||||
|
||||
-- | Add OpenGraph image meta tag to the head of the page
|
||||
--
|
||||
-- Best practices:
|
||||
--
|
||||
-- * Use custom images for shareable pages, e.g., homepage, articles, etc.
|
||||
-- * Use your logo or any other branded image for the rest of your pages.
|
||||
-- * Use images with a 1.91:1 ratio and minimum recommended dimensions of
|
||||
-- 1200x630 for optimal clarity across all devices.
|
||||
--
|
||||
-- Source: https://ahrefs.com/blog/open-graph-meta-tags/
|
||||
--
|
||||
-- @since 1.6.18
|
||||
setOGImage :: MonadWidget m => Text -> m ()
|
||||
setOGImage a = toWidgetHead $ [hamlet|<meta property="og:image" content=#{a}>|]
|
||||
|
||||
-- | Link to the specified local stylesheet.
|
||||
addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
|
||||
addStylesheet = flip addStylesheetAttrs []
|
||||
@ -305,7 +181,7 @@ addStylesheetAttrs :: MonadWidget m
|
||||
=> Route (HandlerSite m)
|
||||
-> [(Text, Text)]
|
||||
-> m ()
|
||||
addStylesheetAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
|
||||
addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemote :: MonadWidget m => Text -> m ()
|
||||
@ -313,7 +189,7 @@ addStylesheetRemote = flip addStylesheetRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
|
||||
addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
|
||||
addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
|
||||
|
||||
addStylesheetEither :: MonadWidget m
|
||||
=> Either (Route (HandlerSite m)) Text
|
||||
@ -331,7 +207,7 @@ addScript = flip addScriptAttrs []
|
||||
|
||||
-- | Link to the specified local script.
|
||||
addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()
|
||||
addScriptAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
|
||||
addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemote :: MonadWidget m => Text -> m ()
|
||||
@ -339,7 +215,7 @@ addScriptRemote = flip addScriptRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
|
||||
addScriptRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
|
||||
addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
|
||||
|
||||
whamlet :: QuasiQuoter
|
||||
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
|
||||
|
||||
@ -11,7 +11,6 @@ module Yesod.Routes.Parse
|
||||
, TypeTree (..)
|
||||
, dropBracket
|
||||
, nameToType
|
||||
, isTvar
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH.Syntax
|
||||
@ -36,15 +35,9 @@ parseRoutes = QuasiQuoter { quoteExp = x }
|
||||
[] -> lift res
|
||||
z -> error $ unlines $ "Overlapping routes: " : map show z
|
||||
|
||||
-- | Same as 'parseRoutes', but uses an external file instead of quasiquotation.
|
||||
--
|
||||
-- The recommended file extension is @.yesodroutes@.
|
||||
parseRoutesFile :: FilePath -> Q Exp
|
||||
parseRoutesFile = parseRoutesFileWith parseRoutes
|
||||
|
||||
-- | Same as 'parseRoutesNoCheck', but uses an external file instead of quasiquotation.
|
||||
--
|
||||
-- The recommended file extension is @.yesodroutes@.
|
||||
parseRoutesFileNoCheck :: FilePath -> Q Exp
|
||||
parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck
|
||||
|
||||
@ -265,13 +258,8 @@ ttToType (TTApp x y) = ttToType x `AppT` ttToType y
|
||||
ttToType (TTList t) = ListT `AppT` ttToType t
|
||||
|
||||
nameToType :: String -> Type
|
||||
nameToType t = if isTvar t
|
||||
then VarT $ mkName t
|
||||
else ConT $ mkName t
|
||||
|
||||
isTvar :: String -> Bool
|
||||
isTvar (h:_) = isLower h
|
||||
isTvar _ = False
|
||||
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 $ dropBracket x)
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}
|
||||
module Yesod.Routes.TH.Dispatch
|
||||
( MkDispatchSettings (..)
|
||||
@ -74,7 +73,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
|
||||
handlePiece (Static str) = return (LitP $ StringL str, Nothing)
|
||||
handlePiece (Dynamic _) = do
|
||||
x <- newName "dyn"
|
||||
let pat = ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x])
|
||||
let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])
|
||||
return (pat, Just $ VarE x)
|
||||
|
||||
handlePieces :: [Piece a] -> Q ([Pat], [Exp])
|
||||
@ -87,7 +86,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
|
||||
mkPathPat final =
|
||||
foldr addPat final
|
||||
where
|
||||
addPat x y = conPCompat '(:) [x, y]
|
||||
addPat x y = ConP '(:) [x, y]
|
||||
|
||||
go :: SDC -> ResourceTree a -> Q Clause
|
||||
go sdc (ResourceParent name _check pieces children) = do
|
||||
@ -125,11 +124,11 @@ mkDispatchClause MkDispatchSettings {..} resources = do
|
||||
Methods multi methods -> do
|
||||
(finalPat, mfinalE) <-
|
||||
case multi of
|
||||
Nothing -> return (conPCompat '[] [], Nothing)
|
||||
Nothing -> return (ConP '[] [], Nothing)
|
||||
Just _ -> do
|
||||
multiName <- newName "multi"
|
||||
let pat = ViewP (VarE 'fromPathMultiPiece)
|
||||
(conPCompat 'Just [VarP multiName])
|
||||
(ConP 'Just [VarP multiName])
|
||||
return (pat, Just $ VarE multiName)
|
||||
|
||||
let dynsMulti =
|
||||
@ -201,10 +200,3 @@ mkDispatchClause MkDispatchSettings {..} resources = do
|
||||
defaultGetHandler :: Maybe String -> String -> Q Exp
|
||||
defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s
|
||||
defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s
|
||||
|
||||
conPCompat :: Name -> [Pat] -> Pat
|
||||
conPCompat n pats = ConP n
|
||||
#if MIN_VERSION_template_haskell(2,18,0)
|
||||
[]
|
||||
#endif
|
||||
pats
|
||||
|
||||
@ -1,20 +1,9 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
|
||||
{-# LANGUAGE TemplateHaskell, CPP #-}
|
||||
module Yesod.Routes.TH.RenderRoute
|
||||
( -- ** RenderRoute
|
||||
mkRenderRouteInstance
|
||||
, mkRenderRouteInstanceOpts
|
||||
, mkRouteCons
|
||||
, mkRouteConsOpts
|
||||
, mkRenderRouteClauses
|
||||
|
||||
, RouteOpts
|
||||
, defaultOpts
|
||||
, setEqDerived
|
||||
, setShowDerived
|
||||
, setReadDerived
|
||||
) where
|
||||
|
||||
import Yesod.Routes.TH.Types
|
||||
@ -27,67 +16,16 @@ import Data.Text (pack)
|
||||
import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
|
||||
import Yesod.Routes.Class
|
||||
|
||||
-- | General opts data type for generating yesod.
|
||||
--
|
||||
-- Contains options for what instances are derived for the route. Use the setting
|
||||
-- functions on `defaultOpts` to set specific fields.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
data RouteOpts = MkRouteOpts
|
||||
{ roDerivedEq :: Bool
|
||||
, roDerivedShow :: Bool
|
||||
, roDerivedRead :: Bool
|
||||
}
|
||||
|
||||
-- | Default options for generating routes.
|
||||
--
|
||||
-- Defaults to all instances derived.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
defaultOpts :: RouteOpts
|
||||
defaultOpts = MkRouteOpts True True True
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
setEqDerived :: Bool -> RouteOpts -> RouteOpts
|
||||
setEqDerived b rdo = rdo { roDerivedEq = b }
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
setShowDerived :: Bool -> RouteOpts -> RouteOpts
|
||||
setShowDerived b rdo = rdo { roDerivedShow = b }
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
setReadDerived :: Bool -> RouteOpts -> RouteOpts
|
||||
setReadDerived b rdo = rdo { roDerivedRead = b }
|
||||
|
||||
-- |
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
instanceNamesFromOpts :: RouteOpts -> [Name]
|
||||
instanceNamesFromOpts (MkRouteOpts eq shw rd) = prependIf eq ''Eq $ prependIf shw ''Show $ prependIf rd ''Read []
|
||||
where prependIf b = if b then (:) else const id
|
||||
|
||||
-- | Generate the constructors of a route data type.
|
||||
mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])
|
||||
mkRouteCons = mkRouteConsOpts defaultOpts
|
||||
|
||||
-- | Generate the constructors of a route data type, with custom opts.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkRouteConsOpts :: RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])
|
||||
mkRouteConsOpts opts rttypes =
|
||||
mkRouteCons rttypes =
|
||||
mconcat <$> mapM mkRouteCon rttypes
|
||||
where
|
||||
mkRouteCon (ResourceLeaf res) =
|
||||
return ([con], [])
|
||||
where
|
||||
con = NormalC (mkName $ resourceName res)
|
||||
$ map (notStrict,)
|
||||
$ map (\x -> (notStrict, x))
|
||||
$ concat [singles, multi, sub]
|
||||
singles = concatMap toSingle $ resourcePieces res
|
||||
toSingle Static{} = []
|
||||
@ -101,17 +39,16 @@ mkRouteConsOpts opts rttypes =
|
||||
_ -> []
|
||||
|
||||
mkRouteCon (ResourceParent name _check pieces children) = do
|
||||
(cons, decs) <- mkRouteConsOpts opts children
|
||||
let conts = mapM conT $ instanceNamesFromOpts opts
|
||||
(cons, decs) <- mkRouteCons children
|
||||
#if MIN_VERSION_template_haskell(2,12,0)
|
||||
dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) conts
|
||||
dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq])
|
||||
#else
|
||||
dec <- DataD [] (mkName name) [] Nothing cons <$> conts
|
||||
dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]
|
||||
#endif
|
||||
return ([con], dec : decs)
|
||||
where
|
||||
con = NormalC (mkName name)
|
||||
$ map (notStrict,)
|
||||
$ map (\x -> (notStrict, x))
|
||||
$ singles ++ [ConT $ mkName name]
|
||||
|
||||
singles = concatMap toSingle pieces
|
||||
@ -130,7 +67,7 @@ mkRenderRouteClauses =
|
||||
let cnt = length $ filter isDynamic pieces
|
||||
dyns <- replicateM cnt $ newName "dyn"
|
||||
child <- newName "child"
|
||||
let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child]
|
||||
let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]
|
||||
|
||||
pack' <- [|pack|]
|
||||
tsp <- [|toPathPiece|]
|
||||
@ -163,7 +100,7 @@ mkRenderRouteClauses =
|
||||
case resourceDispatch res of
|
||||
Subsite{} -> return <$> newName "sub"
|
||||
_ -> return []
|
||||
let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub
|
||||
let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
|
||||
|
||||
pack' <- [|pack|]
|
||||
tsp <- [|toPathPiece|]
|
||||
@ -215,19 +152,9 @@ mkRenderRouteClauses =
|
||||
-- 'renderRoute' method. This function uses both 'mkRouteCons' and
|
||||
-- 'mkRenderRouteClasses'.
|
||||
mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
|
||||
mkRenderRouteInstance = mkRenderRouteInstanceOpts defaultOpts
|
||||
|
||||
-- | Generate the 'RenderRoute' instance.
|
||||
--
|
||||
-- This includes both the 'Route' associated type and the
|
||||
-- 'renderRoute' method. This function uses both 'mkRouteCons' and
|
||||
-- 'mkRenderRouteClasses'.
|
||||
--
|
||||
-- @since 1.6.25.0
|
||||
mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
|
||||
mkRenderRouteInstanceOpts opts cxt typ ress = do
|
||||
mkRenderRouteInstance cxt typ ress = do
|
||||
cls <- mkRenderRouteClauses ress
|
||||
(cons, decs) <- mkRouteConsOpts opts ress
|
||||
(cons, decs) <- mkRouteCons ress
|
||||
#if MIN_VERSION_template_haskell(2,15,0)
|
||||
did <- DataInstD [] Nothing (AppT (ConT ''Route) typ) Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
|
||||
let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
|
||||
@ -248,17 +175,10 @@ mkRenderRouteInstanceOpts opts cxt typ ress = do
|
||||
clazzes'
|
||||
else
|
||||
[]
|
||||
clazzes' = instanceNamesFromOpts opts
|
||||
clazzes' = [''Show, ''Eq, ''Read]
|
||||
|
||||
notStrict :: Bang
|
||||
notStrict = Bang NoSourceUnpackedness NoSourceStrictness
|
||||
|
||||
instanceD :: Cxt -> Type -> [Dec] -> Dec
|
||||
instanceD = InstanceD Nothing
|
||||
|
||||
conPCompat :: Name -> [Pat] -> Pat
|
||||
conPCompat n pats = ConP n
|
||||
#if MIN_VERSION_template_haskell(2,18,0)
|
||||
[]
|
||||
#endif
|
||||
pats
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Yesod.Routes.TH.RouteAttrs
|
||||
@ -27,11 +26,7 @@ goTree front (ResourceParent name _check pieces trees) =
|
||||
toIgnore = length $ filter isDynamic pieces
|
||||
isDynamic Dynamic{} = True
|
||||
isDynamic Static{} = False
|
||||
front' = front . ConP (mkName name)
|
||||
#if MIN_VERSION_template_haskell(2,18,0)
|
||||
[]
|
||||
#endif
|
||||
. ignored
|
||||
front' = front . ConP (mkName name) . ignored
|
||||
|
||||
goRes :: (Pat -> Pat) -> Resource a -> Q Clause
|
||||
goRes front Resource {..} =
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- | Warning! This module is considered internal and may have breaking changes
|
||||
module Yesod.Routes.TH.Types
|
||||
( -- * Data types
|
||||
@ -21,7 +21,7 @@ import Language.Haskell.TH.Syntax
|
||||
data ResourceTree typ
|
||||
= ResourceLeaf (Resource typ)
|
||||
| ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ]
|
||||
deriving (Lift, Show, Functor)
|
||||
deriving (Show, Functor)
|
||||
|
||||
resourceTreePieces :: ResourceTree typ -> [Piece typ]
|
||||
resourceTreePieces (ResourceLeaf r) = resourcePieces r
|
||||
@ -31,6 +31,10 @@ resourceTreeName :: ResourceTree typ -> String
|
||||
resourceTreeName (ResourceLeaf r) = resourceName r
|
||||
resourceTreeName (ResourceParent x _ _ _) = x
|
||||
|
||||
instance Lift t => Lift (ResourceTree t) where
|
||||
lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]
|
||||
lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|]
|
||||
|
||||
data Resource typ = Resource
|
||||
{ resourceName :: String
|
||||
, resourcePieces :: [Piece typ]
|
||||
@ -38,17 +42,24 @@ data Resource typ = Resource
|
||||
, resourceAttrs :: [String]
|
||||
, resourceCheck :: CheckOverlap
|
||||
}
|
||||
deriving (Lift, Show, Functor)
|
||||
deriving (Show, Functor)
|
||||
|
||||
type CheckOverlap = Bool
|
||||
|
||||
instance Lift t => Lift (Resource t) where
|
||||
lift (Resource a b c d e) = [|Resource a b c d e|]
|
||||
|
||||
data Piece typ = Static String | Dynamic typ
|
||||
deriving (Lift, Show)
|
||||
deriving Show
|
||||
|
||||
instance Functor Piece where
|
||||
fmap _ (Static s) = Static s
|
||||
fmap f (Dynamic t) = Dynamic (f t)
|
||||
|
||||
instance Lift t => Lift (Piece t) where
|
||||
lift (Static s) = [|Static $(lift s)|]
|
||||
lift (Dynamic t) = [|Dynamic $(lift t)|]
|
||||
|
||||
data Dispatch typ =
|
||||
Methods
|
||||
{ methodsMulti :: Maybe typ -- ^ type of the multi piece at the end
|
||||
@ -58,12 +69,17 @@ data Dispatch typ =
|
||||
{ subsiteType :: typ
|
||||
, subsiteFunc :: String
|
||||
}
|
||||
deriving (Lift, Show)
|
||||
deriving Show
|
||||
|
||||
instance Functor Dispatch where
|
||||
fmap f (Methods a b) = Methods (fmap f a) b
|
||||
fmap f (Subsite a b) = Subsite (f a) b
|
||||
|
||||
instance Lift t => Lift (Dispatch t) where
|
||||
lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
|
||||
lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]
|
||||
lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]
|
||||
|
||||
resourceMulti :: Resource typ -> Maybe typ
|
||||
resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
|
||||
resourceMulti _ = Nothing
|
||||
|
||||
@ -227,7 +227,7 @@ main = hspec $ do
|
||||
describe "routing table parsing" $ do
|
||||
it "recognizes trailing backslashes as line continuation directives" $ do
|
||||
let routes :: [ResourceTree String]
|
||||
routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations.yesodroutes")
|
||||
routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations")
|
||||
length routes @?= 3
|
||||
|
||||
describe "overlap checking" $ do
|
||||
|
||||
@ -5,16 +5,12 @@ import YesodCoreTest.CleanPath
|
||||
import YesodCoreTest.Exceptions
|
||||
import YesodCoreTest.Widget
|
||||
import YesodCoreTest.Media
|
||||
import YesodCoreTest.Meta
|
||||
import YesodCoreTest.Links
|
||||
import YesodCoreTest.Header
|
||||
import YesodCoreTest.NoOverloadedStrings
|
||||
import YesodCoreTest.SubSub
|
||||
import YesodCoreTest.InternalRequest
|
||||
import YesodCoreTest.ErrorHandling
|
||||
import YesodCoreTest.Cache
|
||||
import YesodCoreTest.ParameterizedSite
|
||||
import YesodCoreTest.Breadcrumb
|
||||
import qualified YesodCoreTest.WaiSubsite as WaiSubsite
|
||||
import qualified YesodCoreTest.Redirect as Redirect
|
||||
import qualified YesodCoreTest.JsLoader as JsLoader
|
||||
@ -44,11 +40,9 @@ specs = do
|
||||
mediaTest
|
||||
linksTest
|
||||
noOverloadedTest
|
||||
subSubTest
|
||||
internalRequestTest
|
||||
errorHandlingTest
|
||||
cacheTest
|
||||
parameterizedSiteTest
|
||||
WaiSubsite.specs
|
||||
Redirect.specs
|
||||
JsLoader.specs
|
||||
@ -65,5 +59,3 @@ specs = do
|
||||
Ssl.sslOnlySpec
|
||||
Ssl.sameSiteSpec
|
||||
Csrf.csrfSpec
|
||||
breadcrumbTest
|
||||
metaTest
|
||||
|
||||
@ -1,58 +0,0 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module YesodCoreTest.Breadcrumb
|
||||
( breadcrumbTest,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
import Data.Text (Text)
|
||||
import Data.Typeable (Typeable)
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import Test.Hspec
|
||||
import UnliftIO.IORef
|
||||
import Yesod.Core
|
||||
|
||||
data A = A
|
||||
|
||||
mkYesod
|
||||
"A"
|
||||
[parseRoutes|
|
||||
/ RootR GET
|
||||
/loop LoopR GET
|
||||
|]
|
||||
|
||||
instance Yesod A
|
||||
|
||||
instance YesodBreadcrumbs A where
|
||||
breadcrumb r = case r of
|
||||
RootR -> pure ("Root", Nothing)
|
||||
LoopR -> pure ("Loop", Just LoopR) -- Purposefully a loop
|
||||
|
||||
getRootR :: Handler Text
|
||||
getRootR = fst <$> breadcrumbs
|
||||
|
||||
getLoopR :: Handler Text
|
||||
getLoopR = fst <$> breadcrumbs
|
||||
|
||||
breadcrumbTest :: Spec
|
||||
breadcrumbTest =
|
||||
describe "Test.Breadcrumb" $ do
|
||||
it "can fetch the root which contains breadcrumbs" $
|
||||
runner $ do
|
||||
res <- request defaultRequest
|
||||
assertStatus 200 res
|
||||
it "gets a 500 for a route with a looping breadcrumb" $
|
||||
runner $ do
|
||||
res <- request defaultRequest {pathInfo = ["loop"]}
|
||||
assertStatus 500 res
|
||||
|
||||
runner :: Session () -> IO ()
|
||||
runner f = toWaiApp A >>= runSession f
|
||||
@ -1,37 +1,26 @@
|
||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module YesodCoreTest.ErrorHandling
|
||||
( errorHandlingTest
|
||||
, Widget
|
||||
, resourcesApp
|
||||
) where
|
||||
|
||||
import Data.Typeable(cast)
|
||||
import qualified System.Mem as Mem
|
||||
import qualified Control.Concurrent.Async as Async
|
||||
import Control.Concurrent as Conc
|
||||
import Yesod.Core
|
||||
import Test.Hspec
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Control.Exception (SomeException, try, AsyncException(..))
|
||||
import UnliftIO.Exception(finally)
|
||||
import Control.Exception (SomeException, try)
|
||||
import Network.HTTP.Types (Status, mkStatus)
|
||||
import Data.ByteString.Builder (Builder, toLazyByteString)
|
||||
import Data.Monoid (mconcat)
|
||||
import Data.Text (Text, pack)
|
||||
import Control.Monad (forM_)
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom
|
||||
import Control.Monad.Trans.State (StateT (..))
|
||||
import Control.Monad.Trans.Reader (ReaderT (..))
|
||||
import qualified UnliftIO.Exception as E
|
||||
import System.Timeout(timeout)
|
||||
|
||||
data App = App
|
||||
|
||||
@ -56,10 +45,6 @@ mkYesod "App" [parseRoutes|
|
||||
/auth-not-adequate AuthNotAdequateR GET
|
||||
/args-not-valid ArgsNotValidR POST
|
||||
/only-plain-text OnlyPlainTextR GET
|
||||
|
||||
/thread-killed ThreadKilledR GET
|
||||
/connection-closed-by-peer ConnectionClosedPeerR GET
|
||||
/sleep-sec SleepASecR GET
|
||||
|]
|
||||
|
||||
overrideStatus :: Status
|
||||
@ -126,23 +111,6 @@ goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n"
|
||||
getGoodBuilderR :: Handler TypedContent
|
||||
getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
|
||||
|
||||
-- this handler kills it's own thread
|
||||
getThreadKilledR :: Handler Html
|
||||
getThreadKilledR = do
|
||||
x <- liftIO Conc.myThreadId
|
||||
liftIO $ Async.withAsync (Conc.killThread x) Async.wait
|
||||
pure "unreachablle"
|
||||
getSleepASecR :: Handler Html
|
||||
getSleepASecR = do
|
||||
liftIO $ Conc.threadDelay 1000000
|
||||
pure "slept a second"
|
||||
|
||||
getConnectionClosedPeerR :: Handler Html
|
||||
getConnectionClosedPeerR = do
|
||||
x <- liftIO Conc.myThreadId
|
||||
liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait
|
||||
pure "unreachablle"
|
||||
|
||||
getErrorR :: Int -> Handler ()
|
||||
getErrorR 1 = setSession undefined "foo"
|
||||
getErrorR 2 = setSession "foo" undefined
|
||||
@ -186,10 +154,6 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
|
||||
it "accept CSS, permission denied -> 403" caseCssPermissionDenied
|
||||
it "accept image, non-existent path -> 404" caseImageNotFound
|
||||
it "accept video, bad method -> 405" caseVideoBadMethod
|
||||
it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows
|
||||
it "custom config rethrows an exception" caseCustomExceptionRethrows
|
||||
it "thread killed rethrow" caseThreadKilledRethrow
|
||||
it "can timeout a runner" canTimeoutARunner
|
||||
|
||||
runner :: Session a -> IO a
|
||||
runner f = toWaiApp App >>= runSession f
|
||||
@ -327,50 +291,3 @@ caseVideoBadMethod = runner $ do
|
||||
("accept", "video/webm") : requestHeaders defaultRequest
|
||||
}
|
||||
assertStatus 405 res
|
||||
|
||||
fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e
|
||||
fromExceptionUnwrap se
|
||||
| Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e
|
||||
| Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e
|
||||
| otherwise = E.fromException se
|
||||
|
||||
|
||||
caseThreadKilledRethrow :: IO ()
|
||||
caseThreadKilledRethrow =
|
||||
shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
|
||||
(Just ThreadKilled) -> True
|
||||
_ -> False
|
||||
where
|
||||
testcode = runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["thread-killed"] }
|
||||
assertStatus 500 res
|
||||
assertBodyContains "Internal Server Error" res
|
||||
|
||||
caseDefaultConnectionCloseRethrows :: IO ()
|
||||
caseDefaultConnectionCloseRethrows =
|
||||
shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
|
||||
Just Warp.ConnectionClosedByPeer -> True
|
||||
_ -> False
|
||||
|
||||
where
|
||||
testcode = runner $ do
|
||||
_res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] }
|
||||
pure ()
|
||||
|
||||
caseCustomExceptionRethrows :: IO ()
|
||||
caseCustomExceptionRethrows =
|
||||
shouldThrow testcode $ \case Custom.MkMyException -> True
|
||||
where
|
||||
testcode = customAppRunner $ do
|
||||
_res <- request defaultRequest { pathInfo = ["throw-custom-exception"] }
|
||||
pure ()
|
||||
customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f
|
||||
|
||||
|
||||
canTimeoutARunner :: IO ()
|
||||
canTimeoutARunner = do
|
||||
res <- timeout 1000 $ runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["sleep-sec"] }
|
||||
assertStatus 200 res -- if 500, it's catching the timeout exception
|
||||
pure () -- it should've timeout by now, either being 500 or Nothing
|
||||
res `shouldBe` Nothing -- make sure that pure statement didn't happen.
|
||||
|
||||
@ -1,41 +0,0 @@
|
||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
|
||||
-- | a custom app that throws an exception
|
||||
module YesodCoreTest.ErrorHandling.CustomApp
|
||||
(CustomApp(..)
|
||||
, MyException(..)
|
||||
|
||||
-- * unused
|
||||
, Widget
|
||||
, resourcesCustomApp
|
||||
) where
|
||||
|
||||
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core
|
||||
import qualified UnliftIO.Exception as E
|
||||
|
||||
data CustomApp = CustomApp
|
||||
|
||||
mkYesod "CustomApp" [parseRoutes|
|
||||
/throw-custom-exception CustomHomeR GET
|
||||
|]
|
||||
|
||||
getCustomHomeR :: Handler Html
|
||||
getCustomHomeR =
|
||||
E.throwIO MkMyException
|
||||
|
||||
data MyException = MkMyException
|
||||
deriving (Show, E.Exception)
|
||||
|
||||
instance Yesod CustomApp where
|
||||
-- something we couldn't do before, rethrow custom exceptions
|
||||
catchHandlerExceptions _ action handler =
|
||||
action `E.catch` \exception -> do
|
||||
case E.fromException exception of
|
||||
Just MkMyException -> E.throwIO MkMyException
|
||||
Nothing -> handler exception
|
||||
@ -1,54 +0,0 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module YesodCoreTest.Meta
|
||||
( metaTest
|
||||
) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Yesod.Core
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
|
||||
data App = App
|
||||
|
||||
mkYesod "App" [parseRoutes|
|
||||
/title TitleR GET
|
||||
/desc DescriptionR GET
|
||||
|]
|
||||
|
||||
instance Yesod App where
|
||||
|
||||
getTitleR :: Handler Html
|
||||
getTitleR = defaultLayout $ do
|
||||
setTitle "First title"
|
||||
setTitle "Second title"
|
||||
|
||||
getDescriptionR :: Handler Html
|
||||
getDescriptionR = defaultLayout $ do
|
||||
setDescriptionIdemp "First description"
|
||||
setDescriptionIdemp "Second description"
|
||||
|
||||
metaTest :: Spec
|
||||
metaTest = describe "Setting page metadata" $ do
|
||||
describe "Yesod.Core.Widget.setTitle" $ do
|
||||
it "is idempotent" $ runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["title"]
|
||||
}
|
||||
assertBody "<!DOCTYPE html>\n<html><head><title>Second title</title></head><body></body></html>" res
|
||||
describe "Yesod.Core.Widget.setDescriptionIdemp" $ do
|
||||
it "is idempotent" $ runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["desc"]
|
||||
}
|
||||
assertBody "<!DOCTYPE html>\n<html><head><title></title><meta name=\"description\" content=\"Second description\"></head><body></body></html>" res
|
||||
|
||||
runner :: Session () -> IO ()
|
||||
runner f = toWaiAppPlain App >>= runSession f
|
||||
@ -1,37 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module YesodCoreTest.ParameterizedSite
|
||||
( parameterizedSiteTest
|
||||
) where
|
||||
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Network.Wai.Test (runSession, request, defaultRequest, assertBodyContains)
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Yesod.Core (YesodDispatch)
|
||||
import Yesod.Core.Dispatch (toWaiApp)
|
||||
|
||||
import YesodCoreTest.ParameterizedSite.PolyAny (PolyAny (..))
|
||||
import YesodCoreTest.ParameterizedSite.PolyShow (PolyShow (..))
|
||||
import YesodCoreTest.ParameterizedSite.Compat (Compat (..))
|
||||
|
||||
-- These are actually tests for template haskell. So if it compiles, it works
|
||||
parameterizedSiteTest :: Spec
|
||||
parameterizedSiteTest = describe "Polymorphic Yesod sites" $ do
|
||||
it "Polymorphic unconstrained stub" $ runStub (PolyAny ())
|
||||
it "Polymorphic stub with Show" $ runStub' "1337" (PolyShow 1337)
|
||||
it "Polymorphic unconstrained stub, old-style" $ runStub (Compat () ())
|
||||
|
||||
runStub :: YesodDispatch a => a -> IO ()
|
||||
runStub stub =
|
||||
let actions = do
|
||||
res <- request defaultRequest
|
||||
assertBodyContains "Stub" res
|
||||
in toWaiApp stub >>= runSession actions
|
||||
|
||||
|
||||
runStub' :: YesodDispatch a => ByteString -> a -> IO ()
|
||||
runStub' body stub =
|
||||
let actions = do
|
||||
res <- request defaultRequest
|
||||
assertBodyContains "Stub" res
|
||||
assertBodyContains body res
|
||||
in toWaiApp stub >>= runSession actions
|
||||
@ -1,27 +0,0 @@
|
||||
{-# LANGUAGE
|
||||
TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
|
||||
, OverloadedStrings, StandaloneDeriving, FlexibleInstances
|
||||
#-}
|
||||
module YesodCoreTest.ParameterizedSite.Compat
|
||||
( Compat (..)
|
||||
) where
|
||||
|
||||
import Yesod.Core
|
||||
|
||||
-- | Parameterized without constraints, and we call mkYesod without type vars,
|
||||
-- like people used to do before the last 3 commits
|
||||
data Compat a b = Compat a b
|
||||
|
||||
mkYesod "Compat" [parseRoutes|
|
||||
/ HomeR GET
|
||||
|]
|
||||
|
||||
instance Yesod (Compat a b)
|
||||
|
||||
getHomeR :: Handler a b Html
|
||||
getHomeR = defaultLayout
|
||||
[whamlet|
|
||||
<p>
|
||||
Stub
|
||||
|]
|
||||
|
||||
@ -1,26 +0,0 @@
|
||||
{-# LANGUAGE
|
||||
TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
|
||||
, OverloadedStrings, StandaloneDeriving, FlexibleInstances
|
||||
#-}
|
||||
module YesodCoreTest.ParameterizedSite.PolyAny
|
||||
( PolyAny (..)
|
||||
) where
|
||||
|
||||
import Yesod.Core
|
||||
|
||||
-- | Parameterized without constraints
|
||||
data PolyAny a = PolyAny a
|
||||
|
||||
mkYesod "PolyAny a" [parseRoutes|
|
||||
/ HomeR GET
|
||||
|]
|
||||
|
||||
instance Yesod (PolyAny a)
|
||||
|
||||
getHomeR :: Handler a Html
|
||||
getHomeR = defaultLayout
|
||||
[whamlet|
|
||||
<p>
|
||||
Stub
|
||||
|]
|
||||
|
||||
@ -1,28 +0,0 @@
|
||||
{-# LANGUAGE
|
||||
TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
|
||||
, OverloadedStrings, StandaloneDeriving, FlexibleInstances
|
||||
#-}
|
||||
module YesodCoreTest.ParameterizedSite.PolyShow
|
||||
( PolyShow (..)
|
||||
) where
|
||||
|
||||
import Yesod.Core
|
||||
|
||||
-- | Parameterized with 'Show' constraint
|
||||
data PolyShow a = PolyShow a
|
||||
|
||||
mkYesod "(Show a) => PolyShow a" [parseRoutes|
|
||||
/ HomeR GET
|
||||
|]
|
||||
|
||||
instance Show a => Yesod (PolyShow a)
|
||||
|
||||
getHomeR :: Show a => Handler a Html
|
||||
getHomeR = do
|
||||
PolyShow x <- getYesod
|
||||
defaultLayout
|
||||
[whamlet|
|
||||
<p>
|
||||
Stub #{show x}
|
||||
|]
|
||||
|
||||
@ -1,50 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module YesodCoreTest.SubSub where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Yesod.Core
|
||||
import Network.Wai.Test
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
|
||||
import YesodCoreTest.SubSubData
|
||||
|
||||
data App = App { getOuter :: OuterSubSite }
|
||||
|
||||
mkYesod "App" [parseRoutes|
|
||||
/ OuterSubSiteR OuterSubSite getOuter
|
||||
|]
|
||||
|
||||
instance Yesod App
|
||||
|
||||
getSubR :: SubHandlerFor InnerSubSite master T.Text
|
||||
getSubR = return $ T.pack "sub"
|
||||
|
||||
instance YesodSubDispatch OuterSubSite master where
|
||||
yesodSubDispatch = $(mkYesodSubDispatch resourcesOuterSubSite)
|
||||
|
||||
instance YesodSubDispatch InnerSubSite master where
|
||||
yesodSubDispatch = $(mkYesodSubDispatch resourcesInnerSubSite)
|
||||
|
||||
app :: App
|
||||
app = App { getOuter = OuterSubSite { getInner = InnerSubSite }}
|
||||
|
||||
runner :: Session () -> IO ()
|
||||
runner f = toWaiApp app >>= runSession f
|
||||
|
||||
case_subSubsite :: IO ()
|
||||
case_subSubsite = runner $ do
|
||||
res <- request defaultRequest
|
||||
assertBody (L8.pack "sub") res
|
||||
assertStatus 200 res
|
||||
|
||||
subSubTest :: Spec
|
||||
subSubTest = describe "YesodCoreTest.SubSub" $ do
|
||||
it "sub_subsite" case_subSubsite
|
||||
@ -1,20 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module YesodCoreTest.SubSubData where
|
||||
|
||||
import Yesod.Core
|
||||
|
||||
|
||||
data OuterSubSite = OuterSubSite { getInner :: InnerSubSite }
|
||||
|
||||
data InnerSubSite = InnerSubSite
|
||||
|
||||
mkYesodSubData "InnerSubSite" [parseRoutes|
|
||||
/ SubR GET
|
||||
|]
|
||||
|
||||
mkYesodSubData "OuterSubSite" [parseRoutes|
|
||||
/ InnerSubSiteR InnerSubSite getInner
|
||||
|]
|
||||
@ -98,7 +98,7 @@ widgetTest = describe "Test.Widget" $ do
|
||||
assertBody "<!DOCTYPE html>\n<html><head><title></title><script>toHead</script><toHead></toHead>\n<style>toWidget{bar:baz}toHead{bar:baz}</style></head><body><script>toBody</script><p>toWidget</p>\n<p>toBody</p>\n<script>toWidget</script></body></html>" res
|
||||
|
||||
runner :: Session () -> IO ()
|
||||
runner f = toWaiAppPlain Y >>= runSession f
|
||||
runner f = toWaiApp Y >>= runSession f
|
||||
|
||||
case_addJuliusBody :: IO ()
|
||||
case_addJuliusBody = runner $ do
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-core
|
||||
version: 1.6.25.1
|
||||
version: 1.6.17.3
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -8,7 +8,7 @@ synopsis: Creation of type-safe, RESTful web applications.
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-core>
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.10
|
||||
cabal-version: >= 1.8
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
extra-source-files:
|
||||
@ -17,17 +17,15 @@ extra-source-files:
|
||||
test/YesodCoreTest/JsLoaderSites/Bottom.hs
|
||||
test/en.msg
|
||||
test/test.hs
|
||||
test/fixtures/routes_with_line_continuations.yesodroutes
|
||||
test/fixtures/routes_with_line_continuations
|
||||
ChangeLog.md
|
||||
README.md
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: src
|
||||
|
||||
build-depends: base >= 4.10 && < 5
|
||||
, aeson >= 1.0
|
||||
, attoparsec-aeson >= 2.1
|
||||
, auto-update
|
||||
, blaze-html >= 0.5
|
||||
, blaze-markup >= 0.7.1
|
||||
@ -40,7 +38,6 @@ library
|
||||
, containers >= 0.2
|
||||
, cookie >= 0.4.3 && < 0.5
|
||||
, deepseq >= 1.3
|
||||
, entropy
|
||||
, fast-logger >= 2.2
|
||||
, http-types >= 0.7
|
||||
, memory
|
||||
@ -49,7 +46,7 @@ library
|
||||
, parsec >= 2 && < 3.2
|
||||
, path-pieces >= 0.1.2 && < 0.3
|
||||
, primitive >= 0.6
|
||||
, random >= 1.0.0.2 && < 1.3
|
||||
, random >= 1.0.0.2 && < 1.2
|
||||
, resourcet >= 1.2
|
||||
, shakespeare >= 2.0
|
||||
, template-haskell >= 2.11
|
||||
@ -59,7 +56,7 @@ library
|
||||
, unix-compat
|
||||
, unliftio
|
||||
, unordered-containers >= 0.2
|
||||
, vector >= 0.9 && < 0.14
|
||||
, vector >= 0.9 && < 0.13
|
||||
, wai >= 3.2
|
||||
, wai-extra >= 3.0.7
|
||||
, wai-logger >= 0.2
|
||||
@ -100,12 +97,14 @@ library
|
||||
Yesod.Routes.TH.RouteAttrs
|
||||
|
||||
ghc-options: -Wall
|
||||
-- Following line added due to: https://github.com/yesodweb/yesod/issues/545
|
||||
-- This looks like a GHC bug
|
||||
extensions: MultiParamTypeClasses
|
||||
|
||||
-- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
|
||||
other-extensions: TemplateHaskell
|
||||
extensions: TemplateHaskell
|
||||
|
||||
test-suite test-routes
|
||||
default-language: Haskell2010
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: RouteSpec.hs
|
||||
hs-source-dirs: test, src
|
||||
@ -122,7 +121,7 @@ test-suite test-routes
|
||||
Yesod.Routes.TH.Types
|
||||
|
||||
-- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
|
||||
other-extensions: TemplateHaskell
|
||||
extensions: TemplateHaskell
|
||||
|
||||
build-depends: base
|
||||
, hspec
|
||||
@ -135,7 +134,6 @@ test-suite test-routes
|
||||
, HUnit
|
||||
|
||||
test-suite tests
|
||||
default-language: Haskell2010
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: test.hs
|
||||
hs-source-dirs: test
|
||||
@ -147,7 +145,6 @@ test-suite tests
|
||||
YesodCoreTest.Header
|
||||
YesodCoreTest.Csrf
|
||||
YesodCoreTest.ErrorHandling
|
||||
YesodCoreTest.ErrorHandling.CustomApp
|
||||
YesodCoreTest.Exceptions
|
||||
YesodCoreTest.InternalRequest
|
||||
YesodCoreTest.JsLoader
|
||||
@ -157,13 +154,8 @@ test-suite tests
|
||||
YesodCoreTest.LiteApp
|
||||
YesodCoreTest.Media
|
||||
YesodCoreTest.MediaData
|
||||
YesodCoreTest.Meta
|
||||
YesodCoreTest.NoOverloadedStrings
|
||||
YesodCoreTest.NoOverloadedStringsSub
|
||||
YesodCoreTest.ParameterizedSite
|
||||
YesodCoreTest.ParameterizedSite.Compat
|
||||
YesodCoreTest.ParameterizedSite.PolyAny
|
||||
YesodCoreTest.ParameterizedSite.PolyShow
|
||||
YesodCoreTest.RawResponse
|
||||
YesodCoreTest.Redirect
|
||||
YesodCoreTest.Reps
|
||||
@ -174,8 +166,6 @@ test-suite tests
|
||||
YesodCoreTest.StubSslOnly
|
||||
YesodCoreTest.StubStrictSameSite
|
||||
YesodCoreTest.StubUnsecured
|
||||
YesodCoreTest.SubSub
|
||||
YesodCoreTest.SubSubData
|
||||
YesodCoreTest.WaiSubsite
|
||||
YesodCoreTest.Widget
|
||||
YesodCoreTest.YesodTest
|
||||
@ -207,10 +197,9 @@ test-suite tests
|
||||
, warp
|
||||
, yesod-core
|
||||
ghc-options: -Wall -threaded
|
||||
other-extensions: TemplateHaskell
|
||||
extensions: TemplateHaskell
|
||||
|
||||
benchmark widgets
|
||||
default-language: Haskell2010
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: bench
|
||||
build-depends: base
|
||||
|
||||
@ -1,7 +1,3 @@
|
||||
## 1.6.0.1
|
||||
|
||||
* Update documentation from `HandlerT` to `HandlerFor` [#1703](https://github.com/yesodweb/yesod/pull/1703)
|
||||
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
|
||||
@ -63,9 +63,9 @@ sourceToSource src =
|
||||
Just x -> yield (Chunk x) >> yield Flush
|
||||
|
||||
|
||||
-- | Return a Server-Sent Event stream given a 'HandlerFor' action
|
||||
-- | Return a Server-Sent Event stream given a 'HandlerT' action
|
||||
-- that is repeatedly called. A state is threaded for the action
|
||||
-- so that it may avoid using @IORefs@. The @HandlerFor@ action
|
||||
-- so that it may avoid using @IORefs@. The @HandlerT@ action
|
||||
-- may sleep or block while waiting for more data. The HTTP
|
||||
-- socket is flushed after every list of simultaneous events.
|
||||
-- The connection is closed as soon as an 'ES.CloseEvent' is
|
||||
|
||||
@ -1,6 +1,5 @@
|
||||
cabal-version: >= 1.10
|
||||
name: yesod-eventsource
|
||||
version: 1.6.0.1
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Felipe Lessa <felipe.lessa@gmail.com>
|
||||
@ -8,13 +7,13 @@ maintainer: Felipe Lessa <felipe.lessa@gmail.com>
|
||||
synopsis: Server-sent events support for Yesod apps.
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.6
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-eventsource>
|
||||
extra-source-files: README.md ChangeLog.md
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
build-depends: base >= 4.10 && < 5
|
||||
, blaze-builder
|
||||
, conduit >= 1.3
|
||||
|
||||
@ -1,30 +1,5 @@
|
||||
# Changelog
|
||||
|
||||
## 1.7.0.2
|
||||
|
||||
* Allow yesod-form 1.7
|
||||
|
||||
## 1.7.0.1
|
||||
|
||||
[#1716](https://github.com/yesodweb/yesod/pull/1716)
|
||||
|
||||
* Fixed bug where duplicating `<option>` tags caused the `value` field to be cleared
|
||||
|
||||
## 1.7.0
|
||||
|
||||
[#1707](https://github.com/yesodweb/yesod/pull/1707)
|
||||
|
||||
* Added delete buttons
|
||||
* Added support for custom text or icons inside add/delete buttons
|
||||
* Added new presets for Bootstrap + Font Awesome icons
|
||||
* Added support for more complex fields that have multiple parts stuch as radio fields
|
||||
* Improved support for fields that rely on hidden inputs like WYSIWYG editors
|
||||
* Fixed redundant class in existing Bootstrap presets
|
||||
* Fixed styling not applying to error messages on individual fields
|
||||
* Tooltips now show once at the top of the multi-field group when using `amulti`
|
||||
|
||||
## 1.6.0
|
||||
|
||||
[#1601](https://github.com/yesodweb/yesod/pull/1601)
|
||||
|
||||
* Added `Yesod.Form.MultiInput` which supports multi-input forms without needing to submit the form to add an input field
|
||||
* Added `Yesod.Form.MultiInput` which supports multi-input forms without needing to submit the form to add an input field [#1601](https://github.com/yesodweb/yesod/pull/1601)
|
||||
@ -1,5 +1,7 @@
|
||||
## yesod-form-multi
|
||||
|
||||
Support for creating forms in which the user can specify how many inputs to submit. Includes support for enforcing a minimum number of values.
|
||||
Intended as an alternative to `Yesod.Form.MassInput`.
|
||||
|
||||
Intended as an alternative to `Yesod.Form.MassInput`.
|
||||
# Limitations
|
||||
- If the user adds too many fields then there is currently no support for a "delete button" although fields submitted empty are considered to be deleted.
|
||||
@ -17,19 +17,16 @@ module Yesod.Form.MultiInput
|
||||
, mmulti
|
||||
, amulti
|
||||
, bs3Settings
|
||||
, bs3FASettings
|
||||
, bs4Settings
|
||||
, bs4FASettings
|
||||
) where
|
||||
|
||||
import Control.Arrow (second)
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.Trans.RWS (ask, tell)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromJust, listToMaybe, fromMaybe, isJust)
|
||||
import Data.Maybe (fromJust, listToMaybe, fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Text.Julius (rawJS)
|
||||
import Yesod.Core
|
||||
import Yesod.Form.Fields (intField)
|
||||
import Yesod.Form.Functions
|
||||
@ -44,132 +41,43 @@ instance ToJavascript Text where toJavascript = toJavascript . toJSON
|
||||
#endif
|
||||
#endif
|
||||
|
||||
-- | By default delete buttons have a @margin-left@ property of @0.75rem@.
|
||||
-- You can override this by specifying an alternative value in a class
|
||||
-- which is then passed inside 'MultiSettings'.
|
||||
--
|
||||
-- @since 1.7.0
|
||||
-- @since 1.6.0
|
||||
data MultiSettings site = MultiSettings
|
||||
{ msAddClass :: !Text -- ^ Class to be applied to the "add another" button.
|
||||
, msDelClass :: !Text -- ^ Class to be applied to the "delete" button.
|
||||
, msTooltipClass :: Text -- ^ Only used in applicative forms. Class to be applied to the tooltip.
|
||||
, msWrapperErrClass :: !Text -- ^ Class to be applied to the wrapper if it's field has an error.
|
||||
, msAddInner :: !(Maybe Html) -- ^ Inner Html of add button, defaults to "Add Another". Useful for adding icons inside buttons.
|
||||
, msDelInner :: !(Maybe Html) -- ^ Inner Html of delete button, defaults to "Delete". Useful for adding icons inside buttons.
|
||||
{ msAddClass :: Text -- ^ Class to be applied to the "add another" button.
|
||||
, msErrWidget :: Maybe (Html -> WidgetFor site ()) -- ^ Only used in applicative forms. Create a widget for displaying errors.
|
||||
}
|
||||
|
||||
-- | The general structure of each individually generated field is as follows.
|
||||
-- There is an external wrapper element containing both an inner wrapper and any
|
||||
-- error messages that apply to that specific field. The inner wrapper contains
|
||||
-- both the field and it's corresponding delete button.
|
||||
--
|
||||
-- The structure is illustrated by the following:
|
||||
--
|
||||
-- > <div .#{wrapperClass}>
|
||||
-- > <div .#{wrapperClass}-inner>
|
||||
-- > ^{fieldWidget}
|
||||
-- > ^{deleteButton}
|
||||
-- > ^{maybeErrorMessages}
|
||||
--
|
||||
-- Each wrapper element has the same class which is automatically generated. This class
|
||||
-- is returned in the 'MultiView' should you wish to change the styling. The inner wrapper
|
||||
-- uses the same class followed by @-inner@. By default the wrapper and inner wrapper has
|
||||
-- classes are as follows:
|
||||
--
|
||||
-- > .#{wrapperClass} {
|
||||
-- > margin-bottom: 1rem;
|
||||
-- > }
|
||||
-- >
|
||||
-- > .#{wrapperClass}-inner {
|
||||
-- > display: flex;
|
||||
-- > flex-direction: row;
|
||||
-- > }
|
||||
--
|
||||
-- @since 1.7.0
|
||||
-- @since 1.6.0
|
||||
data MultiView site = MultiView
|
||||
{ mvCounter :: FieldView site -- ^ Hidden counter field.
|
||||
, mvFields :: [FieldView site] -- ^ Input fields.
|
||||
, mvAddBtn :: FieldView site -- ^ Button to add another field.
|
||||
, mvWrapperClass :: Text -- ^ Class applied to a div wrapping each field with it's delete button.
|
||||
}
|
||||
|
||||
-- | 'MultiSettings' for Bootstrap 3.
|
||||
--
|
||||
-- @since 1.6.0
|
||||
bs3Settings :: MultiSettings site
|
||||
bs3Settings = MultiSettings
|
||||
"btn btn-default"
|
||||
"btn btn-danger"
|
||||
"help-block"
|
||||
"has-error"
|
||||
Nothing Nothing (Just errW)
|
||||
bs3Settings = MultiSettings "btn btn-default" (Just errW)
|
||||
where
|
||||
errW err =
|
||||
[whamlet|
|
||||
<span .help-block>#{err}
|
||||
<span .help-block .error-block>#{err}
|
||||
|]
|
||||
|
||||
-- | 'MultiSettings' for Bootstrap 4.
|
||||
--
|
||||
-- @since 1.6.0
|
||||
bs4Settings :: MultiSettings site
|
||||
bs4Settings = MultiSettings
|
||||
"btn btn-secondary"
|
||||
"btn btn-danger"
|
||||
"form-text text-muted"
|
||||
"has-error"
|
||||
Nothing Nothing (Just errW)
|
||||
bs4Settings = MultiSettings "btn btn-basic" (Just errW)
|
||||
where
|
||||
errW err =
|
||||
[whamlet|
|
||||
<div .invalid-feedback>#{err}
|
||||
|]
|
||||
|
||||
-- | 'MultiSettings' for Bootstrap 3 with Font Awesome 5 Icons.
|
||||
-- Uses @fa-plus@ for the add button and @fa-trash-alt@ for the delete button.
|
||||
--
|
||||
-- @since 1.7.0
|
||||
bs3FASettings :: MultiSettings site
|
||||
bs3FASettings = MultiSettings
|
||||
"btn btn-default"
|
||||
"btn btn-danger"
|
||||
"help-block"
|
||||
"has-error"
|
||||
addIcon delIcon (Just errW)
|
||||
where
|
||||
addIcon = Just [shamlet|<i class="fas fa-plus">|]
|
||||
delIcon = Just [shamlet|<i class="fas fa-trash-alt">|]
|
||||
errW err =
|
||||
[whamlet|
|
||||
<span .help-block>#{err}
|
||||
|]
|
||||
|
||||
-- | 'MultiSettings' for Bootstrap 4 with Font Awesome 5 Icons.
|
||||
-- Uses @fa-plus@ for the add button and @fa-trash-alt@ for the delete button.
|
||||
--
|
||||
-- @since 1.7.0
|
||||
bs4FASettings :: MultiSettings site
|
||||
bs4FASettings = MultiSettings
|
||||
"btn btn-secondary"
|
||||
"btn btn-danger"
|
||||
"form-text text-muted"
|
||||
"has-error"
|
||||
addIcon delIcon (Just errW)
|
||||
where
|
||||
addIcon = Just [shamlet|<i class="fas fa-plus">|]
|
||||
delIcon = Just [shamlet|<i class="fas fa-trash-alt">|]
|
||||
errW err =
|
||||
[whamlet|
|
||||
<div .invalid-feedback>#{err}
|
||||
|]
|
||||
|
||||
-- | Applicative equivalent of 'mmulti'.
|
||||
--
|
||||
-- Note about tooltips:
|
||||
-- Rather than displaying the tooltip alongside each field the
|
||||
-- tooltip is displayed once at the top of the multi-field set.
|
||||
--
|
||||
-- @since 1.6.0
|
||||
amulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
|
||||
=> Field m a
|
||||
@ -184,19 +92,20 @@ amulti field fs defs minVals ms = formToAForm $
|
||||
mform = do
|
||||
(fr, MultiView {..}) <- mmulti field fs defs minVals ms
|
||||
|
||||
let (fv : _) = mvFields
|
||||
widget = do
|
||||
let widget = do
|
||||
[whamlet|
|
||||
$maybe tooltip <- fvTooltip fv
|
||||
<small .#{msTooltipClass ms}>#{tooltip}
|
||||
|
||||
^{fvInput mvCounter}
|
||||
|
||||
$forall fv <- mvFields
|
||||
^{fvInput fv}
|
||||
|
||||
$maybe err <- fvErrors fv
|
||||
$maybe errW <- msErrWidget ms
|
||||
^{errW err}
|
||||
|
||||
^{fvInput mvAddBtn}
|
||||
|]
|
||||
(fv : _) = mvFields
|
||||
view = FieldView
|
||||
{ fvLabel = fvLabel fv
|
||||
, fvTooltip = Nothing
|
||||
@ -221,10 +130,11 @@ mmulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
|
||||
-> Int
|
||||
-> MultiSettings site
|
||||
-> MForm m (FormResult [a], MultiView site)
|
||||
mmulti field fs defs minVals' ms = do
|
||||
wrapperClass <- lift newIdent
|
||||
let minVals = if minVals' < 0 then 0 else minVals'
|
||||
mhelperMulti field fs wrapperClass defs minVals ms
|
||||
mmulti field fs@FieldSettings {..} defs minVals ms = do
|
||||
fieldClass <- newFormIdent
|
||||
let fs' = fs {fsAttrs = addClass fieldClass fsAttrs}
|
||||
minVals' = if minVals < 0 then 0 else minVals
|
||||
mhelperMulti field fs' fieldClass defs minVals' ms
|
||||
|
||||
-- Helper function, does most of the work for mmulti.
|
||||
mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
|
||||
@ -235,22 +145,21 @@ mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMe
|
||||
-> Int
|
||||
-> MultiSettings site
|
||||
-> MForm m (FormResult [a], MultiView site)
|
||||
mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals MultiSettings {..} = do
|
||||
mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals MultiSettings {..} = do
|
||||
mp <- askParams
|
||||
(_, site, langs) <- ask
|
||||
name <- maybe newFormIdent return fsName
|
||||
theId <- lift $ maybe newIdent return fsId
|
||||
theId <- maybe newFormIdent return fsId
|
||||
cName <- newFormIdent
|
||||
cid <- lift newIdent
|
||||
addBtnId <- lift newIdent
|
||||
delBtnPrefix <- lift newIdent
|
||||
cid <- newFormIdent
|
||||
addBtnId <- newFormIdent
|
||||
|
||||
let mr2 = renderMessage site langs
|
||||
cDef = length defs
|
||||
cfs = FieldSettings "" Nothing (Just cid) (Just cName) [("hidden", "true")]
|
||||
mkName i = name `T.append` (T.pack $ '-' : show i)
|
||||
mkId i = theId `T.append` (T.pack $ '-' : show i)
|
||||
mkNames c = [(i, (mkName i, mkId i)) | i <- [0 .. c]]
|
||||
mkNames c = [(mkName i, mkId i) | i <- [0 .. c]]
|
||||
onMissingSucc _ _ = FormSuccess Nothing
|
||||
onMissingFail m l = FormFailure [renderMessage m l MsgValueRequired]
|
||||
isSuccNothing r = case r of
|
||||
@ -265,7 +174,7 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
|
||||
Just p -> mkRes intField cfs p mfs cName onMissingFail FormSuccess
|
||||
|
||||
-- generate counter view
|
||||
cView <- mkView intField cfs cr Nothing Nothing msWrapperErrClass cid cName True
|
||||
cView <- mkView intField cfs cr cid cName True
|
||||
|
||||
let counter = case cRes of
|
||||
FormSuccess c -> c
|
||||
@ -277,74 +186,17 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
|
||||
if cDef == 0
|
||||
then [(FormMissing, Left "")]
|
||||
else [(FormMissing, Right d) | d <- defs]
|
||||
Just p -> mapM
|
||||
(\n -> mkRes field fs p mfs n onMissingSucc (FormSuccess . Just))
|
||||
(map (fst . snd) $ mkNames counter)
|
||||
|
||||
-- delete button
|
||||
|
||||
-- The delFunction is included down with the add button rather than with
|
||||
-- each delete button to ensure that the function only gets included once.
|
||||
let delFunction = toWidget
|
||||
[julius|
|
||||
function deleteField_#{rawJS theId}(wrapper) {
|
||||
var numFields = $('.#{rawJS wrapperClass}').length;
|
||||
|
||||
if (numFields == 1)
|
||||
{
|
||||
wrapper.find("*").each(function() {
|
||||
removeVals($(this));
|
||||
});
|
||||
}
|
||||
else
|
||||
wrapper.remove();
|
||||
}
|
||||
|
||||
function removeVals(e) {
|
||||
// input types where we don't want to reset the value
|
||||
const keepValueTypes = ["radio", "checkbox", "button"];
|
||||
|
||||
var shouldKeep = keepValueTypes.includes(e.prop('type'))
|
||||
|| e.prop("tagName") == "OPTION";
|
||||
|
||||
// uncheck any checkboxes or radio fields and empty any text boxes
|
||||
if(e.prop('checked') == true)
|
||||
e.prop('checked', false);
|
||||
|
||||
if(!shouldKeep)
|
||||
e.val("").trigger("change");
|
||||
// trigger change is to ensure WYSIWYG editors are updated
|
||||
// when their hidden code field is cleared
|
||||
}
|
||||
|]
|
||||
|
||||
mkDelBtn fieldId = do
|
||||
let delBtnId = delBtnPrefix `T.append` fieldId
|
||||
[whamlet|
|
||||
<button ##{delBtnId} .#{msDelClass} style="margin-left: 0.75rem" type="button">
|
||||
$maybe inner <- msDelInner
|
||||
#{inner}
|
||||
$nothing
|
||||
Delete
|
||||
|]
|
||||
toWidget
|
||||
[julius|
|
||||
$('##{rawJS delBtnId}').click(function() {
|
||||
var field = $('##{rawJS fieldId}');
|
||||
deleteField_#{rawJS theId}(field.parents('.#{rawJS wrapperClass}'));
|
||||
});
|
||||
|]
|
||||
Just p -> mapM (\n -> mkRes field fs p mfs n onMissingSucc (FormSuccess . Just)) (map fst $ mkNames counter)
|
||||
|
||||
-- generate field views
|
||||
(rs, fvs) <- do
|
||||
let mkView' ((c, (n,i)), r@(res, _)) = do
|
||||
let del = Just (mkDelBtn i, wrapperClass, c)
|
||||
fv <- mkView field fs r del msErrWidget msWrapperErrClass i n True
|
||||
let mkView' ((n,i), r@(res, _)) = do
|
||||
fv <- mkView field fs r i n False
|
||||
return (res, fv)
|
||||
xs = zip (mkNames counter) results
|
||||
notSuccNothing (_, (r,_)) = not $ isSuccNothing r
|
||||
ys = case filter notSuccNothing xs of
|
||||
[] -> [((0, (mkName 0, mkId 0)), (FormSuccess Nothing, Left ""))] -- always need at least one value to generate a field
|
||||
[] -> [((mkName 0, mkId 0), (FormSuccess Nothing, Left ""))] -- always need at least one value to generate a field
|
||||
zs -> zs
|
||||
rvs <- mapM mkView' ys
|
||||
return $ unzip rvs
|
||||
@ -362,77 +214,23 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
|
||||
fRes -> (fRes, False)
|
||||
|
||||
-- create add button
|
||||
-- also includes some styling / functions that we only want to include once
|
||||
btnWidget = do
|
||||
[whamlet|
|
||||
<button ##{addBtnId} .#{msAddClass} type="button">
|
||||
$maybe inner <- msAddInner
|
||||
#{inner}
|
||||
$nothing
|
||||
Add Another
|
||||
<button ##{addBtnId} .#{msAddClass} type="button">Add Another
|
||||
|]
|
||||
toWidget
|
||||
[lucius|
|
||||
.#{wrapperClass} {
|
||||
margin-bottom: 1rem;
|
||||
}
|
||||
.#{wrapperClass}-inner {
|
||||
display: flex;
|
||||
flex-direction: row;
|
||||
}
|
||||
|]
|
||||
delFunction -- function used by delete buttons, included here so that it only gets included once
|
||||
toWidget
|
||||
[julius|
|
||||
var extraFields_#{rawJS theId} = 0;
|
||||
$('##{rawJS addBtnId}').click(function() {
|
||||
extraFields_#{rawJS theId}++;
|
||||
var newNumber = parseInt(#{show counter}) + extraFields_#{rawJS theId};
|
||||
var extraFields = 0;
|
||||
$("#" + #{addBtnId}).click(function() {
|
||||
extraFields++;
|
||||
var newNumber = parseInt(#{show counter}) + extraFields;
|
||||
$("#" + #{cid}).val(newNumber);
|
||||
var newName = #{name} + "-" + newNumber;
|
||||
var newId = #{theId} + "-" + newNumber;
|
||||
var newDelId = #{delBtnPrefix} + newId;
|
||||
|
||||
// get new wrapper and remove old error messages
|
||||
var newWrapper = $('.#{rawJS wrapperClass}').first().clone();
|
||||
newWrapper.children( ':not(.#{rawJS wrapperClass}-inner)' ).remove();
|
||||
newWrapper.removeClass(#{msWrapperErrClass});
|
||||
|
||||
// get counter from wrapper
|
||||
var oldCount = newWrapper.data("counter");
|
||||
var oldName = #{name} + "-" + oldCount;
|
||||
var oldId = #{theId} + "-" + oldCount;
|
||||
var oldDelBtn = #{delBtnPrefix} + oldId;
|
||||
|
||||
// replace any id, name or for attributes that began with
|
||||
// the old values and replace them with the new values
|
||||
var idRegex = new RegExp("^" + oldId);
|
||||
var nameRegex = new RegExp("^" + oldName);
|
||||
|
||||
var els = newWrapper.find("*");
|
||||
els.each(function() {
|
||||
var e = $(this);
|
||||
|
||||
if(e.prop('id') != undefined)
|
||||
e.prop('id', e.prop('id').replace(idRegex, newId));
|
||||
|
||||
if(e.prop('name') != undefined)
|
||||
e.prop('name', e.prop('name').replace(nameRegex, newName));
|
||||
|
||||
if(e.prop('for') != undefined)
|
||||
e.prop('for', e.prop('for').replace(idRegex, newId)); // radio fields use id in for attribute
|
||||
|
||||
removeVals(e);
|
||||
});
|
||||
|
||||
// set new counter on wrapper
|
||||
newWrapper.attr("data-counter", newNumber);
|
||||
|
||||
var newDelBtn = newWrapper.find('[id^=#{rawJS delBtnPrefix}]');
|
||||
newDelBtn.prop('id', newDelId);
|
||||
newDelBtn.click(() => deleteField_#{rawJS theId}(newWrapper));
|
||||
|
||||
newWrapper.insertBefore('##{rawJS addBtnId}');
|
||||
var newElem = $("." + #{fieldClass}).first().clone();
|
||||
newElem.val("").attr('name', newName).attr('id', newId);
|
||||
newElem.insertBefore("#" + #{addBtnId})
|
||||
});
|
||||
|]
|
||||
|
||||
@ -445,7 +243,7 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
|
||||
, fvRequired = False
|
||||
}
|
||||
|
||||
return (res, MultiView cView fvs btnView wrapperClass)
|
||||
return (res, MultiView cView fvs btnView)
|
||||
|
||||
-- Search for the given field's name in the environment,
|
||||
-- parse any values found and construct a FormResult.
|
||||
@ -476,42 +274,21 @@ mkView :: (site ~ HandlerSite m, MonadHandler m)
|
||||
=> Field m a
|
||||
-> FieldSettings site
|
||||
-> (FormResult b, Either Text a)
|
||||
-- Delete button widget, class for div wrapping each field with it's delete button and counter value for that field.
|
||||
-- Nothing if the field passed doesn't need a delete button e.g. if it is the counter field.
|
||||
-> Maybe (WidgetFor site (), Text, Int)
|
||||
-> Maybe (Html -> WidgetFor site ()) -- Function to display error messages.
|
||||
-> Text
|
||||
-> Text
|
||||
-> Text
|
||||
-> Bool
|
||||
-> MForm m (FieldView site)
|
||||
mkView Field {..} FieldSettings {..} (res, val) mdel merrW errClass theId name isReq = do
|
||||
mkView Field {..} FieldSettings {..} (res, val) theId name isReq = do
|
||||
(_, site, langs) <- ask
|
||||
let mr2 = renderMessage site langs
|
||||
merr = case res of
|
||||
FormFailure [e] -> Just $ toHtml e
|
||||
_ -> Nothing
|
||||
fv' = fieldView theId name fsAttrs val isReq
|
||||
fv = do
|
||||
[whamlet|
|
||||
$maybe (delBtn, wrapperClass, counter) <- mdel
|
||||
<div .#{wrapperClass} :isJust merr:.#{errClass} data-counter=#{counter}>
|
||||
<div .#{wrapperClass}-inner>
|
||||
^{fv'}
|
||||
^{delBtn}
|
||||
|
||||
$maybe err <- merr
|
||||
$maybe errW <- merrW
|
||||
^{errW err}
|
||||
|
||||
$nothing
|
||||
^{fv'}
|
||||
|]
|
||||
return $ FieldView
|
||||
{ fvLabel = toHtml $ mr2 fsLabel
|
||||
, fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
|
||||
, fvId = theId
|
||||
, fvInput = fv
|
||||
, fvErrors = merr
|
||||
, fvInput = fieldView theId name fsAttrs val isReq
|
||||
, fvErrors =
|
||||
case res of
|
||||
FormFailure [e] -> Just $ toHtml e
|
||||
_ -> Nothing
|
||||
, fvRequired = isReq
|
||||
}
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-form-multi
|
||||
version: 1.7.0.2
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: James Burton <jamesejburton@gmail.com>
|
||||
@ -7,7 +7,7 @@ maintainer: James Burton <jamesejburton@gmail.com>
|
||||
synopsis: Multi-input form handling for Yesod Web Framework
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.10
|
||||
cabal-version: >= 1.8
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-form-multi>.
|
||||
@ -19,14 +19,13 @@ flag network-uri
|
||||
default: True
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
build-depends: base >= 4.10 && < 5
|
||||
, containers >= 0.2
|
||||
, shakespeare >= 2.0
|
||||
, text >= 0.9
|
||||
, transformers >= 0.2.2
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, yesod-form >= 1.6 && < 1.8
|
||||
, yesod-form >= 1.6 && < 1.7
|
||||
|
||||
if flag(network-uri)
|
||||
build-depends: network-uri >= 2.6
|
||||
|
||||
@ -1,33 +1,5 @@
|
||||
# ChangeLog for yesod-form
|
||||
|
||||
## 1.7.6
|
||||
|
||||
* Added `datetimeLocalField` for creating a html `<input type="datetime-local">` [#1817](https://github.com/yesodweb/yesod/pull/1817)
|
||||
|
||||
## 1.7.5
|
||||
|
||||
* Add Romanian translation [#1801](https://github.com/yesodweb/yesod/pull/1801)
|
||||
|
||||
## 1.7.4
|
||||
|
||||
* Added a `Monad AForm` instance only when `transformers` >= 0.6 [#1795](https://github.com/yesodweb/yesod/pull/1795)
|
||||
|
||||
## 1.7.3
|
||||
|
||||
* Fixed `radioField` according to Bootstrap 3 docs. [#1783](https://github.com/yesodweb/yesod/pull/1783)
|
||||
|
||||
## 1.7.2
|
||||
|
||||
* Added `withRadioField` and re-express `radioField` into that. [#1775](https://github.com/yesodweb/yesod/pull/1775)
|
||||
|
||||
## 1.7.1
|
||||
|
||||
* Added `colorField` for creating a html color field (`<input type="color">`) [#1748](https://github.com/yesodweb/yesod/pull/1748)
|
||||
|
||||
## 1.7.0
|
||||
|
||||
* Extended `OptionList` by `OptionListGrouped` and implemented grouped select fields (`<select>` with `<optgroup>`) [#1722](https://github.com/yesodweb/yesod/pull/1722)
|
||||
|
||||
## 1.6.7
|
||||
|
||||
* Added equivalent version of `mreqMsg` for `areq` and `wreq` correspondingly [#1628](https://github.com/yesodweb/yesod/pull/1628)
|
||||
|
||||
@ -3,7 +3,7 @@
|
||||
Form handling for Yesod, in the same style as formlets. See [the forms
|
||||
chapter](http://www.yesodweb.com/book/forms) of the Yesod book.
|
||||
|
||||
This package provides a set of basic form inputs such as text, number, time,
|
||||
This package provies a set of basic form inputs such as text, number, time,
|
||||
checkbox, select, textarea, and etc. via `Yesod.Form.Fields` module. Also,
|
||||
there is `Yesod.Form.Nic` module providing richtext field using Nic editor.
|
||||
However, this module is grandfathered now and Nic editor is not actively
|
||||
|
||||
@ -3,7 +3,6 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- | Field functions allow you to easily create and validate forms, cleanly handling the uncertainty of parsing user input.
|
||||
@ -46,10 +45,8 @@ module Yesod.Form.Fields
|
||||
, selectFieldHelper
|
||||
, selectField
|
||||
, selectFieldList
|
||||
, selectFieldListGrouped
|
||||
, radioField
|
||||
, radioFieldList
|
||||
, withRadioField
|
||||
, checkboxesField
|
||||
, checkboxesFieldList
|
||||
, multiSelectField
|
||||
@ -57,14 +54,10 @@ module Yesod.Form.Fields
|
||||
, Option (..)
|
||||
, OptionList (..)
|
||||
, mkOptionList
|
||||
, mkOptionListGrouped
|
||||
, optionsPersist
|
||||
, optionsPersistKey
|
||||
, optionsPairs
|
||||
, optionsPairsGrouped
|
||||
, optionsEnum
|
||||
, colorField
|
||||
, datetimeLocalField
|
||||
) where
|
||||
|
||||
import Yesod.Form.Types
|
||||
@ -75,7 +68,7 @@ import Text.Blaze (ToMarkup (toMarkup), unsafeByteString)
|
||||
#define ToHtml ToMarkup
|
||||
#define toHtml toMarkup
|
||||
#define preEscapedText preEscapedToMarkup
|
||||
import Data.Time (Day, TimeOfDay(..), LocalTime (LocalTime))
|
||||
import Data.Time (Day, TimeOfDay(..))
|
||||
import qualified Text.Email.Validate as Email
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
@ -87,7 +80,7 @@ import Database.Persist (Entity (..), SqlType (SqlString), PersistRecordBackend,
|
||||
import Database.Persist (Entity (..), SqlType (SqlString), PersistEntity, PersistQuery, PersistEntityBackend)
|
||||
#endif
|
||||
import Text.HTML.SanitizeXSS (sanitizeBalance)
|
||||
import Control.Monad (when, unless, forM_)
|
||||
import Control.Monad (when, unless)
|
||||
import Data.Either (partitionEithers)
|
||||
import Data.Maybe (listToMaybe, fromMaybe)
|
||||
|
||||
@ -99,8 +92,7 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Text as T ( Text, append, concat, cons, head
|
||||
, intercalate, isPrefixOf, null, unpack, pack
|
||||
, split, splitOn
|
||||
, intercalate, isPrefixOf, null, unpack, pack, splitOn
|
||||
)
|
||||
import qualified Data.Text as T (drop, dropWhile)
|
||||
import qualified Data.Text.Read
|
||||
@ -121,8 +113,6 @@ import Data.String (IsString)
|
||||
import Data.Monoid
|
||||
#endif
|
||||
|
||||
import Data.Char (isHexDigit)
|
||||
|
||||
defaultFormMessage :: FormMessage -> Text
|
||||
defaultFormMessage = englishFormMessage
|
||||
|
||||
@ -179,20 +169,20 @@ timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Tim
|
||||
timeField = timeFieldTypeTime
|
||||
|
||||
-- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'.
|
||||
--
|
||||
--
|
||||
-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
|
||||
--
|
||||
-- @since 1.4.2
|
||||
timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
|
||||
-- Since 1.4.2
|
||||
timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
|
||||
timeFieldTypeTime = timeFieldOfType "time"
|
||||
|
||||
-- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system).
|
||||
--
|
||||
-- This function exists for backwards compatibility with the old implementation of 'timeField', which used to use @type="text"@. Consider using 'timeField' or 'timeFieldTypeTime' for improved UX and validation from the browser.
|
||||
--
|
||||
--
|
||||
-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
|
||||
--
|
||||
-- @since 1.4.2
|
||||
-- Since 1.4.2
|
||||
timeFieldTypeText :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
|
||||
timeFieldTypeText = timeFieldOfType "text"
|
||||
|
||||
@ -225,7 +215,7 @@ $newline never
|
||||
where showVal = either id (pack . renderHtml)
|
||||
|
||||
-- | A newtype wrapper around a 'Text' whose 'ToMarkup' instance converts newlines to HTML @\<br>@ tags.
|
||||
--
|
||||
--
|
||||
-- (When text is entered into a @\<textarea>@, newline characters are used to separate lines.
|
||||
-- If this text is then placed verbatim into HTML, the lines won't be separated, thus the need for replacing with @\<br>@ tags).
|
||||
-- If you don't need this functionality, simply use 'unTextarea' to access the raw text.
|
||||
@ -354,7 +344,7 @@ timeParser = do
|
||||
if i < 0 || i >= 60
|
||||
then fail $ show $ msg $ pack xy
|
||||
else return $ fromIntegral (i :: Int)
|
||||
|
||||
|
||||
-- | Creates an input with @type="email"@. Yesod will validate the email's correctness according to RFC5322 and canonicalize it by removing comments and whitespace (see "Text.Email.Validate").
|
||||
emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
|
||||
emailField = Field
|
||||
@ -372,7 +362,7 @@ $newline never
|
||||
|
||||
-- | Creates an input with @type="email"@ with the <http://w3c.github.io/html/sec-forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'.
|
||||
--
|
||||
-- @since 1.3.7
|
||||
-- Since 1.3.7
|
||||
multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
|
||||
multiEmailField = Field
|
||||
{ fieldParse = parseHelper $
|
||||
@ -437,15 +427,7 @@ selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg
|
||||
-> Field (HandlerFor site) a
|
||||
selectFieldList = selectField . optionsPairs
|
||||
|
||||
-- | Creates a @\<select>@ tag with @\<optgroup>@s for selecting one option.
|
||||
--
|
||||
-- @since 1.7.0
|
||||
selectFieldListGrouped :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
|
||||
=> [(msg, [(msg, a)])]
|
||||
-> Field (HandlerFor site) a
|
||||
selectFieldListGrouped = selectField . optionsPairsGrouped
|
||||
|
||||
-- | Creates a @\<select>@ tag with optional @\<optgroup>@s for selecting one option. Example usage:
|
||||
-- | Creates a @\<select>@ tag for selecting one option. Example usage:
|
||||
--
|
||||
-- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing
|
||||
selectField :: (Eq a, RenderMessage site FormMessage)
|
||||
@ -464,9 +446,6 @@ $newline never
|
||||
$newline never
|
||||
<option value=#{value} :isSel:selected>#{text}
|
||||
|]) -- inside
|
||||
(Just $ \label -> [whamlet|
|
||||
<optgroup label=#{label}>
|
||||
|]) -- group label
|
||||
|
||||
-- | Creates a @\<select>@ tag for selecting multiple options.
|
||||
multiSelectFieldList :: (Eq a, RenderMessage site msg)
|
||||
@ -533,58 +512,31 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
|
||||
radioField :: (Eq a, RenderMessage site FormMessage)
|
||||
=> HandlerFor site (OptionList a)
|
||||
-> Field (HandlerFor site) a
|
||||
radioField = withRadioField
|
||||
(\theId optionWidget -> [whamlet|
|
||||
radioField = selectFieldHelper
|
||||
(\theId _name _attrs inside -> [whamlet|
|
||||
$newline never
|
||||
<div .radio>
|
||||
<label for=#{theId}-none>
|
||||
<div>
|
||||
^{optionWidget}
|
||||
_{MsgSelectNone}
|
||||
<div ##{theId}>^{inside}
|
||||
|])
|
||||
(\theId value _isSel text optionWidget -> [whamlet|
|
||||
(\theId name isSel -> [whamlet|
|
||||
$newline never
|
||||
<div .radio>
|
||||
<label for=#{theId}-#{value}>
|
||||
<div>
|
||||
^{optionWidget}
|
||||
\#{text}
|
||||
<label .radio for=#{theId}-none>
|
||||
<div>
|
||||
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
|
||||
_{MsgSelectNone}
|
||||
|])
|
||||
|
||||
|
||||
-- | Allows the user to place the option radio widget somewhere in
|
||||
-- the template.
|
||||
-- For example: If you want a table of radio options to select.
|
||||
-- 'radioField' is an example on how to use this function.
|
||||
--
|
||||
-- @since 1.7.2
|
||||
withRadioField :: (Eq a, RenderMessage site FormMessage)
|
||||
=> (Text -> WidgetFor site ()-> WidgetFor site ()) -- ^ nothing case for mopt
|
||||
-> (Text -> Text -> Bool -> Text -> WidgetFor site () -> WidgetFor site ()) -- ^ cases for values
|
||||
-> HandlerFor site (OptionList a)
|
||||
-> Field (HandlerFor site) a
|
||||
withRadioField nothingFun optFun =
|
||||
selectFieldHelper outside onOpt inside Nothing
|
||||
where
|
||||
outside theId _name _attrs inside' = [whamlet|
|
||||
(\theId name attrs value isSel text -> [whamlet|
|
||||
$newline never
|
||||
<div ##{theId}>^{inside'}
|
||||
|]
|
||||
onOpt theId name isSel = nothingFun theId $ [whamlet|
|
||||
$newline never
|
||||
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
|
||||
|]
|
||||
inside theId name attrs value isSel display =
|
||||
optFun theId value isSel display [whamlet|
|
||||
<input id=#{theId}-#{(value)} type=radio name=#{name} value=#{(value)} :isSel:checked *{attrs}>
|
||||
|]
|
||||
|
||||
<label .radio for=#{theId}-#{value}>
|
||||
<div>
|
||||
<input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
|
||||
\#{text}
|
||||
|])
|
||||
|
||||
-- | Creates a group of radio buttons to answer the question given in the message. Radio buttons are used to allow differentiating between an empty response (@Nothing@) and a no response (@Just False@). Consider using the simpler 'checkBoxField' if you don't need to make this distinction.
|
||||
--
|
||||
-- If this field is optional, the first radio button is labeled "\<None>", the second \"Yes" and the third \"No".
|
||||
--
|
||||
-- If this field is required, the first radio button is labeled \"Yes" and the second \"No".
|
||||
-- If this field is required, the first radio button is labeled \"Yes" and the second \"No".
|
||||
--
|
||||
-- (Exact label titles will depend on localization).
|
||||
boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
|
||||
@ -618,7 +570,7 @@ $newline never
|
||||
t -> Left $ SomeMessage $ MsgInvalidBool t
|
||||
showVal = either (\_ -> False)
|
||||
|
||||
-- | Creates an input with @type="checkbox"@.
|
||||
-- | Creates an input with @type="checkbox"@.
|
||||
-- While the default @'boolField'@ implements a radio button so you
|
||||
-- can differentiate between an empty response (@Nothing@) and a no
|
||||
-- response (@Just False@), this simpler checkbox field returns an empty
|
||||
@ -646,31 +598,15 @@ $newline never
|
||||
showVal = either (\_ -> False)
|
||||
|
||||
-- | A structure holding a list of options. Typically you can use a convenience function like 'mkOptionList' or 'optionsPairs' instead of creating this directly.
|
||||
--
|
||||
-- Extended by 'OptionListGrouped' in 1.7.0.
|
||||
data OptionList a
|
||||
= OptionList
|
||||
data OptionList a = OptionList
|
||||
{ olOptions :: [Option a]
|
||||
, olReadExternal :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue').
|
||||
}
|
||||
| OptionListGrouped
|
||||
{ olOptionsGrouped :: [(Text, [Option a])]
|
||||
, olReadExternalGrouped :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue').
|
||||
}
|
||||
|
||||
-- | Convert grouped 'OptionList' to a normal one.
|
||||
--
|
||||
-- @since 1.7.0
|
||||
flattenOptionList :: OptionList a -> OptionList a
|
||||
flattenOptionList (OptionListGrouped os re) = OptionList (concatMap snd os) re
|
||||
flattenOptionList ol = ol
|
||||
|
||||
-- | @since 1.4.6
|
||||
-- | Since 1.4.6
|
||||
instance Functor OptionList where
|
||||
fmap f (OptionList options readExternal) =
|
||||
fmap f (OptionList options readExternal) =
|
||||
OptionList ((fmap.fmap) f options) (fmap f . readExternal)
|
||||
fmap f (OptionListGrouped options readExternal) =
|
||||
OptionListGrouped (map (\(g, os) -> (g, (fmap.fmap) f os)) options) (fmap f . readExternal)
|
||||
|
||||
-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternal' function.
|
||||
mkOptionList :: [Option a] -> OptionList a
|
||||
@ -679,22 +615,13 @@ mkOptionList os = OptionList
|
||||
, olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os
|
||||
}
|
||||
|
||||
-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternalGrouped' function.
|
||||
--
|
||||
-- @since 1.7.0
|
||||
mkOptionListGrouped :: [(Text, [Option a])] -> OptionList a
|
||||
mkOptionListGrouped os = OptionListGrouped
|
||||
{ olOptionsGrouped = os
|
||||
, olReadExternalGrouped = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) $ concatMap snd os
|
||||
}
|
||||
|
||||
data Option a = Option
|
||||
{ optionDisplay :: Text -- ^ The user-facing label.
|
||||
, optionInternalValue :: a -- ^ The Haskell value being selected.
|
||||
, optionExternalValue :: Text -- ^ The representation of this value stored in the form.
|
||||
}
|
||||
|
||||
-- | @since 1.4.6
|
||||
-- | Since 1.4.6
|
||||
instance Functor Option where
|
||||
fmap f (Option display internal external) = Option display (f internal) external
|
||||
|
||||
@ -710,30 +637,6 @@ optionsPairs opts = do
|
||||
}
|
||||
return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
|
||||
|
||||
-- | Creates an 'OptionList' from a list of (display-value, internal value) pairs.
|
||||
--
|
||||
-- @since 1.7.0
|
||||
optionsPairsGrouped
|
||||
:: forall m msg a. (MonadHandler m, RenderMessage (HandlerSite m) msg)
|
||||
=> [(msg, [(msg, a)])] -> m (OptionList a)
|
||||
optionsPairsGrouped opts = do
|
||||
mr <- getMessageRender
|
||||
let mkOption (external, (display, internal)) =
|
||||
Option { optionDisplay = mr display
|
||||
, optionInternalValue = internal
|
||||
, optionExternalValue = pack $ show external
|
||||
}
|
||||
opts' = enumerateSublists opts :: [(msg, [(Int, (msg, a))])]
|
||||
opts'' = map (\(x, ys) -> (mr x, map mkOption ys)) opts'
|
||||
return $ mkOptionListGrouped opts''
|
||||
|
||||
-- | Helper to enumerate sublists with one consecutive index.
|
||||
enumerateSublists :: forall a b. [(a, [b])] -> [(a, [(Int, b)])]
|
||||
enumerateSublists xss =
|
||||
let yss :: [(Int, (a, [b]))]
|
||||
yss = snd $ foldl (\(i, res) xs -> (i + (length.snd) xs, res ++ [(i, xs)])) (1, []) xss
|
||||
in map (\(i, (x, ys)) -> (x, zip [i :: Int ..] ys)) yss
|
||||
|
||||
-- | Creates an 'OptionList' from an 'Enum', using its 'Show' instance for the user-facing value.
|
||||
optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
|
||||
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
|
||||
@ -789,7 +692,7 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
|
||||
-- | An alternative to 'optionsPersist' which returns just the 'Key' instead of
|
||||
-- the entire 'Entity'.
|
||||
--
|
||||
-- @since 1.3.2
|
||||
-- Since 1.3.2
|
||||
#if MIN_VERSION_persistent(2,5,0)
|
||||
optionsPersistKey
|
||||
:: (YesodPersist site
|
||||
@ -828,7 +731,7 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
|
||||
}) pairs
|
||||
|
||||
-- |
|
||||
-- A helper function for constucting 'selectField's with optional option groups. You may want to use this when you define your custom 'selectField's or 'radioField's.
|
||||
-- A helper function for constucting 'selectField's. You may want to use this when you define your custom 'selectField's or 'radioField's.
|
||||
--
|
||||
-- @since 1.6.2
|
||||
selectFieldHelper
|
||||
@ -836,26 +739,23 @@ selectFieldHelper
|
||||
=> (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()) -- ^ Outermost part of the field
|
||||
-> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional
|
||||
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options
|
||||
-> (Maybe (Text -> WidgetFor site ())) -- ^ Group headers placed inbetween options
|
||||
-> HandlerFor site (OptionList a)
|
||||
-> Field (HandlerFor site) a
|
||||
selectFieldHelper outside onOpt inside grpHdr opts' = Field
|
||||
selectFieldHelper outside onOpt inside opts' = Field
|
||||
{ fieldParse = \x _ -> do
|
||||
opts <- fmap flattenOptionList opts'
|
||||
opts <- opts'
|
||||
return $ selectParser opts x
|
||||
, fieldView = \theId name attrs val isReq -> do
|
||||
opts <- fmap olOptions $ handlerToWidget opts'
|
||||
outside theId name attrs $ do
|
||||
optsFlat <- fmap (olOptions.flattenOptionList) $ handlerToWidget opts'
|
||||
unless isReq $ onOpt theId name $ render optsFlat val `notElem` map optionExternalValue optsFlat
|
||||
opts'' <- handlerToWidget opts'
|
||||
case opts'' of
|
||||
OptionList{} -> constructOptions theId name attrs val isReq optsFlat
|
||||
OptionListGrouped{olOptionsGrouped=grps} -> do
|
||||
forM_ grps $ \(grp, opts) -> do
|
||||
case grpHdr of
|
||||
Just hdr -> hdr grp
|
||||
Nothing -> return ()
|
||||
constructOptions theId name attrs val isReq opts
|
||||
unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
|
||||
flip mapM_ opts $ \opt -> inside
|
||||
theId
|
||||
name
|
||||
((if isReq then (("required", "required"):) else id) attrs)
|
||||
(optionExternalValue opt)
|
||||
((render opts val) == optionExternalValue opt)
|
||||
(optionDisplay opt)
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
where
|
||||
@ -868,14 +768,6 @@ selectFieldHelper outside onOpt inside grpHdr opts' = Field
|
||||
x -> case olReadExternal opts x of
|
||||
Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
|
||||
Just y -> Right $ Just y
|
||||
constructOptions theId name attrs val isReq opts =
|
||||
forM_ opts $ \opt -> inside
|
||||
theId
|
||||
name
|
||||
((if isReq then (("required", "required"):) else id) attrs)
|
||||
(optionExternalValue opt)
|
||||
(render opts val == optionExternalValue opt)
|
||||
(optionDisplay opt)
|
||||
|
||||
-- | Creates an input with @type="file"@.
|
||||
fileField :: Monad m
|
||||
@ -972,52 +864,11 @@ prependZero t0 = if T.null t1
|
||||
then "-0." `T.append` (T.drop 2 t1)
|
||||
else t1
|
||||
|
||||
where t1 = T.dropWhile (==' ') t0
|
||||
where t1 = T.dropWhile ((==) ' ') t0
|
||||
|
||||
-- $optionsOverview
|
||||
-- These functions create inputs where one or more options can be selected from a list.
|
||||
--
|
||||
--
|
||||
-- The basic datastructure used is an 'Option', which combines a user-facing display value, the internal Haskell value being selected, and an external 'Text' stored as the @value@ in the form (used to map back to the internal value). A list of these, together with a function mapping from an external value back to a Haskell value, form an 'OptionList', which several of these functions take as an argument.
|
||||
--
|
||||
--
|
||||
-- Typically, you won't need to create an 'OptionList' directly and can instead make one with functions like 'optionsPairs' or 'optionsEnum'. Alternatively, you can use functions like 'selectFieldList', which use their @[(msg, a)]@ parameter to create an 'OptionList' themselves.
|
||||
|
||||
-- | Creates an input with @type="color"@.
|
||||
-- The input value must be provided in hexadecimal format #rrggbb.
|
||||
--
|
||||
-- @since 1.7.1
|
||||
colorField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
|
||||
colorField = Field
|
||||
{ fieldParse = parseHelper $ \s ->
|
||||
if isHexColor $ unpack s then Right s
|
||||
else Left $ MsgInvalidHexColorFormat s
|
||||
, fieldView = \theId name attrs val _ -> [whamlet|
|
||||
$newline never
|
||||
<input ##{theId} name=#{name} *{attrs} type=color value=#{either id id val}>
|
||||
|]
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
where
|
||||
isHexColor :: String -> Bool
|
||||
isHexColor ['#',a,b,c,d,e,f] = all isHexDigit [a,b,c,d,e,f]
|
||||
isHexColor _ = False
|
||||
|
||||
-- | Creates an input with @type="datetime-local"@.
|
||||
-- The input value must be provided in YYYY-MM-DD(T| )HH:MM[:SS] format.
|
||||
--
|
||||
-- @since 1.7.6
|
||||
datetimeLocalField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m LocalTime
|
||||
datetimeLocalField = Field
|
||||
{ fieldParse = parseHelper $ \s -> case T.split (\c -> (c == 'T') || (c == ' ')) s of
|
||||
[d,t] -> do
|
||||
day <- parseDate $ unpack d
|
||||
time <- parseTime t
|
||||
Right $ LocalTime day time
|
||||
_ -> Left $ MsgInvalidDatetimeFormat s
|
||||
, fieldView = \theId name attrs val isReq -> [whamlet|
|
||||
$newline never
|
||||
<input type=datetime-local ##{theId} name=#{name} value=#{showVal val} *{attrs} :isReq:required>
|
||||
|]
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
where
|
||||
showVal = either id (pack . show)
|
||||
|
||||
@ -24,5 +24,3 @@ chineseFormMessage (MsgInvalidBool t) = "无效的逻辑值: " `mappend` t
|
||||
chineseFormMessage MsgBoolYes = "是"
|
||||
chineseFormMessage MsgBoolNo = "否"
|
||||
chineseFormMessage MsgDelete = "删除?"
|
||||
chineseFormMessage (MsgInvalidHexColorFormat t) = "颜色无效，必须为 #rrggbb 十六进制格式: " `mappend` t
|
||||
chineseFormMessage (MsgInvalidDatetimeFormat t) = "日期時間無效，必須採用 YYYY-MM-DD(T| )HH:MM[:SS] 格式： " `mappend` t
|
||||
|
||||
@ -24,5 +24,3 @@ croatianFormMessage (MsgInvalidBool t) = "Logička vrijednost nije valjana: "
|
||||
croatianFormMessage MsgBoolYes = "Da"
|
||||
croatianFormMessage MsgBoolNo = "Ne"
|
||||
croatianFormMessage MsgDelete = "Izbrisati?"
|
||||
croatianFormMessage (MsgInvalidHexColorFormat t) = "Nevažeća boja, mora biti u #rrggbb heksadecimalnom formatu: " `mappend` t
|
||||
croatianFormMessage (MsgInvalidDatetimeFormat t) = "Nevažeći datum i vrijeme, mora biti u formatu GGGG-MM-DD(T| )HH:MM[:SS]: " `mappend` t
|
||||
|
||||
@ -24,5 +24,3 @@ czechFormMessage (MsgInvalidBool t) = "Neplatná pravdivostní hodnota: " `mappe
|
||||
czechFormMessage MsgBoolYes = "Ano"
|
||||
czechFormMessage MsgBoolNo = "Ne"
|
||||
czechFormMessage MsgDelete = "Smazat?"
|
||||
czechFormMessage (MsgInvalidHexColorFormat t) = "Neplatná barva, musí být v #rrggbb hexadecimálním formátu: " `mappend` t
|
||||
czechFormMessage (MsgInvalidDatetimeFormat t) = "Neplatné datum a čas, musí být ve formátu YYYY-MM-DD(T| )HH:MM[:SS]: " `mappend` t
|
||||
|
||||
@ -24,5 +24,3 @@ dutchFormMessage (MsgInvalidBool t) = "Ongeldige waarheidswaarde: " `mappend`
|
||||
dutchFormMessage MsgBoolYes = "Ja"
|
||||
dutchFormMessage MsgBoolNo = "Nee"
|
||||
dutchFormMessage MsgDelete = "Verwijderen?"
|
||||
dutchFormMessage (MsgInvalidHexColorFormat t) = "Ongeldige kleur, moet de hexadecimale indeling #rrggbb hebben: " `mappend` t
|
||||
dutchFormMessage (MsgInvalidDatetimeFormat t) = "Ongeldige datum/tijd, moet de indeling JJJJ-MM-DD(T| )UU:MM[:SS] hebben: " `mappend` t
|
||||
|
||||
@ -24,5 +24,3 @@ englishFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t
|
||||
englishFormMessage MsgBoolYes = "Yes"
|
||||
englishFormMessage MsgBoolNo = "No"
|
||||
englishFormMessage MsgDelete = "Delete?"
|
||||
englishFormMessage (MsgInvalidHexColorFormat t) = "Invalid color, must be in #rrggbb hexadecimal format: " `mappend` t
|
||||
englishFormMessage (MsgInvalidDatetimeFormat t) = "Invalid datetime, must be in YYYY-MM-DD(T| )HH:MM[:SS] format: " `mappend` t
|
||||
|
||||
@ -24,5 +24,3 @@ frenchFormMessage (MsgInvalidBool t) = "Booléen invalide : " `mappend` t
|
||||
frenchFormMessage MsgBoolYes = "Oui"
|
||||
frenchFormMessage MsgBoolNo = "Non"
|
||||
frenchFormMessage MsgDelete = "Détruire ?"
|
||||
frenchFormMessage (MsgInvalidHexColorFormat t) = "Couleur non valide. doit être au format hexadécimal #rrggbb : " `mappend` t
|
||||
frenchFormMessage (MsgInvalidDatetimeFormat t) = "Date/heure non valide. doit être au format AAAA-MM-JJ(T| )HH:MM[:SS] : " `mappend` t
|
||||
|
||||
@ -24,5 +24,3 @@ germanFormMessage (MsgInvalidBool t) = "Ungültiger Wahrheitswert: " `mappend` t
|
||||
germanFormMessage MsgBoolYes = "Ja"
|
||||
germanFormMessage MsgBoolNo = "Nein"
|
||||
germanFormMessage MsgDelete = "Löschen?"
|
||||
germanFormMessage (MsgInvalidHexColorFormat t) = "Ungültige Farbe, muss im Hexadezimalformat #rrggbb vorliegen: " `mappend` t
|
||||
germanFormMessage (MsgInvalidDatetimeFormat t) = "Ungültige Datums- und Uhrzeitangabe, muss im Format YYYY-MM-DD(T| )HH:MM[:SS] vorliegen: " `mappend` t
|
||||
|
||||
@ -24,5 +24,3 @@ japaneseFormMessage (MsgInvalidBool t) = "無効なbool値です: " `mappend` t
|
||||
japaneseFormMessage MsgBoolYes = "はい"
|
||||
japaneseFormMessage MsgBoolNo = "いいえ"
|
||||
japaneseFormMessage MsgDelete = "削除しますか?"
|
||||
japaneseFormMessage (MsgInvalidHexColorFormat t) = "無効な色。＃rrggbb16進形式である必要があります: " `mappend` t
|
||||
japaneseFormMessage (MsgInvalidDatetimeFormat t) = "無効な日時です。YYYY-MM-DD(T| )HH:MM[:SS] 形式である必要があります: " `mappend` t
|
||||
|
||||
@ -24,5 +24,3 @@ koreanFormMessage (MsgInvalidBool t) = "잘못된 불(boolean)입니다: " `mapp
|
||||
koreanFormMessage MsgBoolYes = "예"
|
||||
koreanFormMessage MsgBoolNo = "아니오"
|
||||
koreanFormMessage MsgDelete = "삭제하시겠습니까?"
|
||||
koreanFormMessage (MsgInvalidHexColorFormat t) = "색상이 잘못되었습니다. #rrggbb 16진수 형식이어야 합니다.: " `mappend` t
|
||||
koreanFormMessage (MsgInvalidDatetimeFormat t) = "날짜/시간이 잘못되었습니다. YYYY-MM-DD(T| )HH:MM[:SS] 형식이어야 합니다.: " `mappend` t
|
||||
|
||||
@ -24,5 +24,3 @@ norwegianBokmålFormMessage MsgBoolYes = "Ja"
|
||||
norwegianBokmålFormMessage MsgBoolNo = "Nei"
|
||||
norwegianBokmålFormMessage MsgDelete = "Slette?"
|
||||
norwegianBokmålFormMessage MsgCsrfWarning = "Som beskyttelse mot «cross-site request forgery»-angrep, vennligst bekreft innsendt skjema."
|
||||
norwegianBokmålFormMessage (MsgInvalidHexColorFormat t) = "Ugyldig farge, må være i #rrggbb heksadesimalt format: " `mappend` t
|
||||
norwegianBokmålFormMessage (MsgInvalidDatetimeFormat t) = "Ugyldig datoklokkeslett, må være i formatet ÅÅÅÅ-MM-DD(T| )HH:MM[:SS]:" `mappend` t
|
||||
|
||||
@ -24,5 +24,3 @@ portugueseFormMessage (MsgInvalidBool t) = "Booleano inválido: " `mappend` t
|
||||
portugueseFormMessage MsgBoolYes = "Sim"
|
||||
portugueseFormMessage MsgBoolNo = "Não"
|
||||
portugueseFormMessage MsgDelete = "Remover?"
|
||||
portugueseFormMessage (MsgInvalidHexColorFormat t) = "Cor inválida, deve estar no formato #rrggbb hexadecimal: " `mappend` t
|
||||
portugueseFormMessage (MsgInvalidDatetimeFormat t) = "Data e hora inválida, deve estar no formato AAAA-MM-DD(T| )HH:MM[:SS]: " `mappend` t
|
||||
|
||||
@ -1,31 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Yesod.Form.I18n.Romanian where
|
||||
|
||||
import Yesod.Form.Types (FormMessage (..))
|
||||
import Data.Monoid (mappend)
|
||||
import Data.Text (Text)
|
||||
|
||||
-- | Romanian translation
|
||||
--
|
||||
-- @since 1.7.5
|
||||
romanianFormMessage :: FormMessage -> Text
|
||||
romanianFormMessage (MsgInvalidInteger t) = "Număr întreg nevalid: " `Data.Monoid.mappend` t
|
||||
romanianFormMessage (MsgInvalidNumber t) = "Număr nevalid: " `mappend` t
|
||||
romanianFormMessage (MsgInvalidEntry t) = "Valoare nevalidă: " `mappend` t
|
||||
romanianFormMessage MsgInvalidTimeFormat = "Oră nevalidă. Formatul necesar este HH:MM[:SS]"
|
||||
romanianFormMessage MsgInvalidDay = "Dată nevalidă. Formatul necesar este AAAA-LL-ZZ"
|
||||
romanianFormMessage (MsgInvalidUrl t) = "Adresă URL nevalidă: " `mappend` t
|
||||
romanianFormMessage (MsgInvalidEmail t) = "Adresă de e-mail nevalidă: " `mappend` t
|
||||
romanianFormMessage (MsgInvalidHour t) = "Oră nevalidă: " `mappend` t
|
||||
romanianFormMessage (MsgInvalidMinute t) = "Minut nevalid: " `mappend` t
|
||||
romanianFormMessage (MsgInvalidSecond t) = "Secundă nevalidă: " `mappend` t
|
||||
romanianFormMessage MsgCsrfWarning = "Ca protecție împotriva atacurilor CSRF, vă rugăm să confirmați trimiterea formularului."
|
||||
romanianFormMessage MsgValueRequired = "Câmp obligatoriu"
|
||||
romanianFormMessage (MsgInputNotFound t) = "Valoare inexistentă: " `mappend` t
|
||||
romanianFormMessage MsgSelectNone = "<Niciuna>"
|
||||
romanianFormMessage (MsgInvalidBool t) = "Valoare booleană nevalidă: " `mappend` t
|
||||
romanianFormMessage MsgBoolYes = "Da"
|
||||
romanianFormMessage MsgBoolNo = "Nu"
|
||||
romanianFormMessage MsgDelete = "Șterge?"
|
||||
romanianFormMessage (MsgInvalidHexColorFormat t) = "Culoare nevalidă. Formatul necesar este #rrggbb în hexazecimal: " `mappend` t
|
||||
romanianFormMessage (MsgInvalidDatetimeFormat t) = "Data și ora nevalidă, trebuie să fie în format AAAA-LL-ZZ(T| )HH:MM[:SS]: " `mappend` t
|
||||
@ -24,5 +24,3 @@ russianFormMessage (MsgInvalidBool t) = "Неверное логическое
|
||||
russianFormMessage MsgBoolYes = "Да"
|
||||
russianFormMessage MsgBoolNo = "Нет"
|
||||
russianFormMessage MsgDelete = "Удалить?"
|
||||
russianFormMessage (MsgInvalidHexColorFormat t) = "Недопустимое значение цвета, должен быть в шестнадцатеричном формате #rrggbb: " `mappend` t
|
||||
russianFormMessage (MsgInvalidDatetimeFormat t) = "Недопустимое значение даты и времени. Должно быть в формате ГГГГ-ММ-ДД(T| )ЧЧ:ММ[:СС]: " `mappend` t
|
||||
|
||||
@ -25,5 +25,3 @@ spanishFormMessage (MsgInvalidBool t) = "Booleano inválido: " `mappend` t
|
||||
spanishFormMessage MsgBoolYes = "Sí"
|
||||
spanishFormMessage MsgBoolNo = "No"
|
||||
spanishFormMessage MsgDelete = "¿Eliminar?"
|
||||
spanishFormMessage (MsgInvalidHexColorFormat t) = "Color no válido, debe estar en formato hexadecimal #rrggbb: " `mappend` t
|
||||
spanishFormMessage (MsgInvalidDatetimeFormat t) = "Fecha y hora no válida; debe estar en formato AAAA-MM-DD(T| )HH:MM[:SS]: " `mappend` t
|
||||
|
||||
@ -24,5 +24,3 @@ swedishFormMessage MsgBoolYes = "Ja"
|
||||
swedishFormMessage MsgBoolNo = "Nej"
|
||||
swedishFormMessage MsgDelete = "Radera?"
|
||||
swedishFormMessage MsgCsrfWarning = "Som skydd mot \"cross-site request forgery\" attacker, vänligen bekräfta skickandet av formuläret."
|
||||
swedishFormMessage (MsgInvalidHexColorFormat t) = "Ogiltig färg, måste vara i #rrggbb hexadecimalt format: " `mappend` t
|
||||
swedishFormMessage (MsgInvalidDatetimeFormat t) = "Ogiltig datumtid, måste vara i formatet ÅÅÅÅ-MM-DD(T| )TT:MM[:SS]: " `mappend` t
|
||||
|
||||
@ -166,18 +166,6 @@ instance Monad m => Applicative (AForm m) where
|
||||
(a, b, ints', c) <- f mr env ints
|
||||
(x, y, ints'', z) <- g mr env ints'
|
||||
return (a <*> x, b . y, ints'', c `mappend` z)
|
||||
|
||||
#if MIN_VERSION_transformers(0,6,0)
|
||||
instance Monad m => Monad (AForm m) where
|
||||
(AForm f) >>= k = AForm $ \mr env ints -> do
|
||||
(a, b, ints', c) <- f mr env ints
|
||||
case a of
|
||||
FormSuccess r -> do
|
||||
(x, y, ints'', z) <- unAForm (k r) mr env ints'
|
||||
return (x, b . y, ints'', c `mappend` z)
|
||||
FormFailure err -> pure (FormFailure err, b, ints', c)
|
||||
FormMissing -> pure (FormMissing, b, ints', c)
|
||||
#endif
|
||||
instance (Monad m, Monoid a) => Monoid (AForm m a) where
|
||||
mempty = pure mempty
|
||||
mappend a b = mappend <$> a <*> b
|
||||
@ -241,6 +229,4 @@ data FormMessage = MsgInvalidInteger Text
|
||||
| MsgBoolYes
|
||||
| MsgBoolNo
|
||||
| MsgDelete
|
||||
| MsgInvalidHexColorFormat Text
|
||||
| MsgInvalidDatetimeFormat Text
|
||||
deriving (Show, Eq, Read)
|
||||
|
||||
@ -1,6 +1,5 @@
|
||||
cabal-version: >= 1.10
|
||||
name: yesod-form
|
||||
version: 1.7.6
|
||||
version: 1.6.7
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -8,9 +7,10 @@ maintainer: Michael Snoyman <michael@snoyman.com>
|
||||
synopsis: Form handling support for Yesod Web Framework
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.8
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-form>. Third-party packages which you can find useful: <http://hackage.haskell.org/package/yesod-form-richtext yesod-form-richtext> - richtext form fields (currently it provides only Summernote support).
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-form>. Third-party packages which you can find useful: <http://hackage.haskell.org/package/yesod-form-richtext yesod-form-richtext> - richtext form fields (currntly it provides only Summernote support).
|
||||
extra-source-files: ChangeLog.md
|
||||
README.md
|
||||
|
||||
@ -19,7 +19,6 @@ flag network-uri
|
||||
default: True
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
build-depends: base >= 4.10 && < 5
|
||||
, aeson
|
||||
, attoparsec >= 0.10
|
||||
@ -33,6 +32,7 @@ library
|
||||
, email-validate >= 1.0
|
||||
, persistent
|
||||
, resourcet
|
||||
, semigroups
|
||||
, shakespeare >= 2.0
|
||||
, text >= 0.9
|
||||
, time >= 1.1.4
|
||||
@ -67,12 +67,10 @@ library
|
||||
Yesod.Form.I18n.Spanish
|
||||
Yesod.Form.I18n.Chinese
|
||||
Yesod.Form.I18n.Korean
|
||||
Yesod.Form.I18n.Romanian
|
||||
-- FIXME Yesod.Helpers.Crud
|
||||
ghc-options: -Wall
|
||||
|
||||
test-suite test
|
||||
default-language: Haskell2010
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: main.hs
|
||||
hs-source-dirs: test
|
||||
|
||||
@ -1,21 +1,5 @@
|
||||
# ChangeLog for yesod-persistent
|
||||
|
||||
## 1.6.0.8
|
||||
|
||||
* Add support for `persistent-2.14` [#1706](https://github.com/yesodweb/yesod/pull/1760)
|
||||
|
||||
## 1.6.0.7
|
||||
|
||||
* Add support for persistent 2.13. [#1723](https://github.com/yesodweb/yesod/pull/1723)
|
||||
|
||||
## 1.6.0.6
|
||||
|
||||
* Add support for persistent 2.12
|
||||
|
||||
## 1.6.0.5
|
||||
|
||||
* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)
|
||||
|
||||
## 1.6.0.4
|
||||
|
||||
* Fix test suite to be compatible with latest `persistent-template`
|
||||
|
||||
@ -25,7 +25,6 @@ module Yesod.Persist.Core
|
||||
import Database.Persist
|
||||
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
|
||||
|
||||
import Data.Foldable (toList)
|
||||
import Yesod.Core
|
||||
import Data.Conduit
|
||||
import Blaze.ByteString.Builder (Builder)
|
||||
@ -34,12 +33,6 @@ import Control.Monad.Trans.Resource
|
||||
import Control.Exception (throwIO)
|
||||
import Yesod.Core.Types (HandlerContents (HCError))
|
||||
import qualified Database.Persist.Sql as SQL
|
||||
#if MIN_VERSION_persistent(2,13,0)
|
||||
import qualified Database.Persist.SqlBackend.Internal as SQL
|
||||
#endif
|
||||
#if MIN_VERSION_persistent(2,14,0)
|
||||
import Database.Persist.Class.PersistEntity
|
||||
#endif
|
||||
|
||||
unSqlPersistT :: a -> a
|
||||
unSqlPersistT = id
|
||||
@ -190,46 +183,26 @@ getBy404 key = do
|
||||
-- is violated.
|
||||
--
|
||||
-- @since 1.4.1
|
||||
#if MIN_VERSION_persistent(2,14,0)
|
||||
insert400
|
||||
:: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend, SafeToInsert val)
|
||||
=> val
|
||||
-> ReaderT backend m (Key val)
|
||||
#elif MIN_VERSION_persistent(2,5,0)
|
||||
insert400
|
||||
:: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend)
|
||||
=> val
|
||||
-> ReaderT backend m (Key val)
|
||||
#if MIN_VERSION_persistent(2,5,0)
|
||||
insert400 :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend)
|
||||
=> val
|
||||
-> ReaderT backend m (Key val)
|
||||
#else
|
||||
insert400
|
||||
:: (MonadIO m, PersistUnique (PersistEntityBackend val), PersistEntity val)
|
||||
=> val
|
||||
-> ReaderT (PersistEntityBackend val) m (Key val)
|
||||
insert400 :: (MonadIO m, PersistUnique (PersistEntityBackend val), PersistEntity val)
|
||||
=> val
|
||||
-> ReaderT (PersistEntityBackend val) m (Key val)
|
||||
#endif
|
||||
insert400 datum = do
|
||||
conflict <- checkUnique datum
|
||||
case conflict of
|
||||
Just unique ->
|
||||
#if MIN_VERSION_persistent(2, 12, 0)
|
||||
-- toList is called here because persistent-2.13 changed this
|
||||
-- to a nonempty list. for versions of persistent prior to 2.13, toList
|
||||
-- will be a no-op. for persistent-2.13, it'll convert the NonEmptyList to
|
||||
-- a List.
|
||||
badRequest' $ map (unFieldNameHS . fst) $ toList $ persistUniqueToFieldNames unique
|
||||
#else
|
||||
badRequest' $ map (unHaskellName . fst) $ persistUniqueToFieldNames unique
|
||||
#endif
|
||||
Nothing -> insert datum
|
||||
|
||||
-- | Same as 'insert400', but doesn’t return a key.
|
||||
--
|
||||
-- @since 1.4.1
|
||||
#if MIN_VERSION_persistent(2,14,0)
|
||||
insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend, SafeToInsert val)
|
||||
=> val
|
||||
-> ReaderT backend m ()
|
||||
|
||||
#elif MIN_VERSION_persistent(2,5,0)
|
||||
#if MIN_VERSION_persistent(2,5,0)
|
||||
insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend)
|
||||
=> val
|
||||
-> ReaderT backend m ()
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies #-}
|
||||
{-# LANGUAGE EmptyDataDecls, FlexibleContexts, GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
@ -1,6 +1,5 @@
|
||||
cabal-version: >= 1.10
|
||||
name: yesod-persistent
|
||||
version: 1.6.0.8
|
||||
version: 1.6.0.4
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -8,17 +7,17 @@ maintainer: Michael Snoyman <michael@snoyman.com>
|
||||
synopsis: Some helpers for using Persistent from Yesod.
|
||||
category: Web, Yesod, Database
|
||||
stability: Stable
|
||||
cabal-version: >= 1.8
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-persistent>
|
||||
extra-source-files: README.md ChangeLog.md
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
build-depends: base >= 4.10 && < 5
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, persistent >= 2.8
|
||||
, persistent-template >= 2.1
|
||||
, persistent >= 2.8 && < 2.11
|
||||
, persistent-template >= 2.1 && < 2.9
|
||||
, transformers >= 0.2.2
|
||||
, blaze-builder
|
||||
, conduit
|
||||
@ -29,12 +28,10 @@ library
|
||||
ghc-options: -Wall
|
||||
|
||||
test-suite test
|
||||
default-language: Haskell2010
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs: test
|
||||
other-modules: Yesod.PersistSpec
|
||||
build-tool-depends: hspec-discover:hspec-discover
|
||||
build-depends: base
|
||||
, hspec
|
||||
, wai-extra
|
||||
|
||||
@ -1,9 +1,3 @@
|
||||
# ChangeLog for yesod-static
|
||||
|
||||
## 1.6.1.0
|
||||
|
||||
* Support reproducible embedded file order [#1684](https://github.com/yesodweb/yesod/issues/1684#issuecomment-652562514)
|
||||
|
||||
## 1.6.0.2
|
||||
|
||||
* Remove unnecessary deriving of Typeable
|
||||
|
||||
@ -49,7 +49,6 @@ import qualified System.Process as Proc
|
||||
import System.Exit (ExitCode (ExitSuccess))
|
||||
import Control.Concurrent.Async (Concurrently (..))
|
||||
import System.IO (hClose)
|
||||
import Data.List (sort)
|
||||
|
||||
import Yesod.EmbeddedStatic.Types
|
||||
|
||||
@ -81,7 +80,7 @@ getRecursiveContents :: Location -- ^ The directory to search
|
||||
-> FilePath -- ^ The prefix to add to the filenames
|
||||
-> IO [(Location,FilePath)]
|
||||
getRecursiveContents prefix topdir = do
|
||||
names <- sort <$> getDirectoryContents topdir
|
||||
names <- getDirectoryContents topdir
|
||||
let properNames = filter (`notElem` [".", ".."]) names
|
||||
paths <- forM properNames $ \name -> do
|
||||
let path = topdir </> name
|
||||
|
||||
@ -71,7 +71,7 @@ import Data.FileEmbed (embedDir)
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Types
|
||||
|
||||
import Data.List (intercalate, sort)
|
||||
import Data.List (intercalate)
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax as TH
|
||||
|
||||
@ -192,7 +192,7 @@ getFileListPieces = flip evalStateT M.empty . flip go id
|
||||
-> ([String] -> [String])
|
||||
-> StateT (M.Map String String) IO [[String]]
|
||||
go fp front = do
|
||||
allContents <- liftIO $ (sort . filter notHidden) `fmap` getDirectoryContents fp
|
||||
allContents <- liftIO $ filter notHidden `fmap` getDirectoryContents fp
|
||||
let fullPath :: String -> String
|
||||
fullPath f = fp ++ '/' : f
|
||||
files <- liftIO $ filterM (doesFileExist . fullPath) allContents
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-static
|
||||
version: 1.6.1.0
|
||||
version: 1.6.0.2
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -7,7 +7,7 @@ maintainer: Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweb
|
||||
synopsis: Static file serving subsite for Yesod Web Framework.
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.10
|
||||
cabal-version: >= 1.8
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-static>
|
||||
@ -26,7 +26,6 @@ extra-source-files:
|
||||
README.md
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
build-depends: base >= 4.10 && < 5
|
||||
, async
|
||||
, attoparsec >= 0.10
|
||||
@ -67,10 +66,9 @@ library
|
||||
Yesod.EmbeddedStatic.Css.Util
|
||||
|
||||
ghc-options: -Wall
|
||||
other-extensions: TemplateHaskell
|
||||
extensions: TemplateHaskell
|
||||
|
||||
test-suite tests
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: ., test
|
||||
main-is: tests.hs
|
||||
type: exitcode-stdio-1.0
|
||||
@ -120,7 +118,7 @@ test-suite tests
|
||||
, rio
|
||||
|
||||
ghc-options: -Wall -threaded
|
||||
other-extensions: TemplateHaskell
|
||||
extensions: TemplateHaskell
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
||||
@ -1,43 +1,5 @@
|
||||
# ChangeLog for yesod-test
|
||||
|
||||
|
||||
## 1.6.16
|
||||
|
||||
* Add `addBareGetParam` to yesod-test. [#1821](https://github.com/yesodweb/yesod/pull/1821)
|
||||
|
||||
## 1.6.15
|
||||
|
||||
* Add `bySelectorLabelContain`. [#1781](https://github.com/yesodweb/yesod/pull/1781)
|
||||
|
||||
## 1.6.14
|
||||
|
||||
* Fix quotes not matching in htmlContain* functions [#1768](https://github.com/yesodweb/yesod/pull/1768).
|
||||
* Add logging of the matches found of these functions [#1768](https://github.com/yesodweb/yesod/pull/1768).
|
||||
* Improved failure messages from `assertEq`. [#1767](https://github.com/yesodweb/yesod/pull/1767)
|
||||
|
||||
## 1.6.13
|
||||
|
||||
* Add `Yesod.Test.Internal.SIO` module to expose the `SIO` type.
|
||||
|
||||
## 1.6.12
|
||||
|
||||
* Fix import in cookie example [#1713](https://github.com/yesodweb/yesod/pull/1713)
|
||||
* Add `MonadState` instance for `SIO`
|
||||
|
||||
## 1.6.11
|
||||
|
||||
* Add missing `HasCallStack`s [#1710](https://github.com/yesodweb/yesod/pull/1710)
|
||||
|
||||
## 1.6.10
|
||||
|
||||
* `statusIs` assertion failures now print a preview of the response body, if the response body is UTF-8 or ASCII. [#1680](https://github.com/yesodweb/yesod/pull/1680/files)
|
||||
* Adds an `Yesod.Test.Internal`, which exposes functions that yesod-test uses. These functions do _not_ constitute a stable API.
|
||||
|
||||
## 1.6.9.1
|
||||
|
||||
* Improve documentation [#1676](https://github.com/yesodweb/yesod/pull/1676)
|
||||
* Require GHC 8.2 (base >= 4.10)
|
||||
|
||||
## 1.6.9
|
||||
|
||||
Add `requireJSONResponse` function [#1646](https://github.com/yesodweb/yesod/pull/1646)
|
||||
|
||||
@ -42,9 +42,9 @@ spec = withApp $ do
|
||||
addToken -- Add the CSRF _token field with the currently shown value.
|
||||
|
||||
-- Lookup field by the text on the labels pointing to them.
|
||||
byLabelExact "Email:" "gustavo@cerati.com"
|
||||
byLabelExact "Password:" "secret"
|
||||
byLabelExact "Confirm:" "secret"
|
||||
byLabel "Email:" "gustavo@cerati.com"
|
||||
byLabel "Password:" "secret"
|
||||
byLabel "Confirm:" "secret"
|
||||
|
||||
it "Sends another form, this one has a file" $ do
|
||||
request $ do
|
||||
|
||||
@ -7,11 +7,10 @@
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
{-|
|
||||
Yesod.Test is a pragmatic framework for testing web applications built
|
||||
using wai.
|
||||
using wai and persistent.
|
||||
|
||||
By pragmatic I may also mean 'dirty'. Its main goal is to encourage integration
|
||||
and system testing of web applications by making everything /easy to test/.
|
||||
@ -25,86 +24,8 @@ This is very useful for testing web applications built in yesod, for example,
|
||||
where your forms may have field names generated by the framework or a randomly
|
||||
generated CSRF token input.
|
||||
|
||||
=== Example project
|
||||
|
||||
The best way to see an example project using yesod-test is to create a scaffolded Yesod project:
|
||||
|
||||
@stack new projectname yesod-sqlite@
|
||||
|
||||
(See https://github.com/commercialhaskell/stack-templates/wiki#yesod for the full list of Yesod templates)
|
||||
|
||||
The scaffolded project makes your database directly available in tests, so you can use 'runDB' to set up
|
||||
Your database is also directly available so you can use 'runDB' to set up
|
||||
backend pre-conditions, or to assert that your session is having the desired effect.
|
||||
It also handles wiping your database between each test.
|
||||
|
||||
=== Example code
|
||||
|
||||
The code below should give you a high-level idea of yesod-test's capabilities.
|
||||
Note that it uses helper functions like @withApp@ and @runDB@ from the scaffolded project; these aren't provided by yesod-test.
|
||||
|
||||
@
|
||||
spec :: Spec
|
||||
spec = withApp $ do
|
||||
describe \"Homepage\" $ do
|
||||
it "loads the homepage with a valid status code" $ do
|
||||
'get' HomeR
|
||||
'statusIs' 200
|
||||
describe \"Login Form\" $ do
|
||||
it "Only allows dashboard access after logging in" $ do
|
||||
'get' DashboardR
|
||||
'statusIs' 401
|
||||
|
||||
'get' HomeR
|
||||
-- Assert a \<p\> tag exists on the page
|
||||
'htmlAnyContain' \"p\" \"Login\"
|
||||
|
||||
-- yesod-test provides a 'RequestBuilder' monad for building up HTTP requests
|
||||
'request' $ do
|
||||
-- Lookup the HTML \<label\> with the text Username, and set a POST parameter for that field with the value Felipe
|
||||
'byLabelExact' \"Username\" \"Felipe\"
|
||||
'byLabelExact' \"Password\" "pass\"
|
||||
'setMethod' \"POST\"
|
||||
'setUrl' SignupR
|
||||
'statusIs' 200
|
||||
|
||||
-- The previous request will have stored a session cookie, so we can access the dashboard now
|
||||
'get' DashboardR
|
||||
'statusIs' 200
|
||||
|
||||
-- Assert a user with the name Felipe was added to the database
|
||||
[Entity userId user] <- runDB $ selectList [] []
|
||||
'assertEq' "A single user named Felipe is created" (userUsername user) \"Felipe\"
|
||||
describe \"JSON\" $ do
|
||||
it "Can make requests using JSON, and parse JSON responses" $ do
|
||||
-- Precondition: Create a user with the name \"George\"
|
||||
runDB $ insert_ $ User \"George\" "pass"
|
||||
|
||||
'request' $ do
|
||||
-- Use the Aeson library to send JSON to the server
|
||||
'setRequestBody' ('Data.Aeson.encode' $ LoginRequest \"George\" "pass")
|
||||
'addRequestHeader' (\"Accept\", "application/json")
|
||||
'addRequestHeader' ("Content-Type", "application/json")
|
||||
'setUrl' LoginR
|
||||
'statusIs' 200
|
||||
|
||||
-- Parse the request's response as JSON
|
||||
(signupResponse :: SignupResponse) <- 'requireJSONResponse'
|
||||
@
|
||||
|
||||
=== HUnit / HSpec integration
|
||||
|
||||
yesod-test is built on top of hspec, which is itself built on top of HUnit.
|
||||
You can use existing assertion functions from those libraries, but you'll need to use `liftIO` with them:
|
||||
|
||||
@
|
||||
liftIO $ actualTimesCalled `'Test.Hspec.Expectations.shouldBe'` expectedTimesCalled -- hspec assertion
|
||||
@
|
||||
|
||||
@
|
||||
liftIO $ 'Test.HUnit.Base.assertBool' "a is greater than b" (a > b) -- HUnit assertion
|
||||
@
|
||||
|
||||
yesod-test provides a handful of assertion functions that are already lifted, such as 'assertEq', as well.
|
||||
|
||||
-}
|
||||
|
||||
@ -152,7 +73,6 @@ module Yesod.Test
|
||||
, setMethod
|
||||
, addPostParam
|
||||
, addGetParam
|
||||
, addBareGetParam
|
||||
, addFile
|
||||
, setRequestBody
|
||||
, RequestBuilder
|
||||
@ -171,7 +91,6 @@ module Yesod.Test
|
||||
, byLabelContain
|
||||
, byLabelPrefix
|
||||
, byLabelSuffix
|
||||
, bySelectorLabelContain
|
||||
, fileByLabel
|
||||
, fileByLabelExact
|
||||
, fileByLabelContain
|
||||
@ -243,21 +162,23 @@ import qualified Network.Socket.Internal as Sock
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Text.Blaze.Renderer.String as Blaze
|
||||
import qualified Text.Blaze as Blaze
|
||||
import Network.Wai
|
||||
import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
|
||||
import Control.Monad.Trans.Reader (ReaderT (..))
|
||||
import Conduit (MonadThrow)
|
||||
import Control.Monad.IO.Class
|
||||
import System.IO
|
||||
import Yesod.Core.Unsafe (runFakeHandler)
|
||||
import Yesod.Test.TransversingCSS
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Json (contentTypeHeaderIsJson)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With)
|
||||
import Text.XML.Cursor hiding (element)
|
||||
import qualified Text.XML.Cursor as C
|
||||
import qualified Text.HTML.DOM as HD
|
||||
import Control.Monad.Trans.Writer
|
||||
import Data.IORef
|
||||
import qualified Data.Map as M
|
||||
import qualified Web.Cookie as Cookie
|
||||
import qualified Blaze.ByteString.Builder as Builder
|
||||
@ -280,9 +201,6 @@ import Network.HTTP.Types.Header (hContentType)
|
||||
import Data.Aeson (FromJSON, eitherDecode')
|
||||
import Control.Monad (unless)
|
||||
|
||||
import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8)
|
||||
import Yesod.Test.Internal.SIO
|
||||
|
||||
{-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-}
|
||||
{-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-}
|
||||
|
||||
@ -432,7 +350,7 @@ yit :: String -> YesodExample site () -> YesodSpec site
|
||||
yit label example = tell [YesodSpecItem label example]
|
||||
|
||||
-- | Modifies the site ('yedSite') of the test, and creates a new WAI app ('yedApp') for it.
|
||||
--
|
||||
--
|
||||
-- yesod-test allows sending requests to your application to test that it handles them correctly.
|
||||
-- In rare cases, you may wish to modify that application in the middle of a test.
|
||||
-- This may be useful if you wish to, for example, test your application under a certain configuration,
|
||||
@ -456,7 +374,7 @@ testModifySite :: YesodDispatch site
|
||||
=> (site -> IO (site, Middleware)) -- ^ A function from the existing site, to a new site and middleware for a WAI app.
|
||||
-> YesodExample site ()
|
||||
testModifySite newSiteFn = do
|
||||
currentSite <- getTestYesod
|
||||
currentSite <- getTestYesod
|
||||
(newSite, middleware) <- liftIO $ newSiteFn currentSite
|
||||
app <- liftIO $ toWaiAppPlain newSite
|
||||
modifySIO $ \yed -> yed { yedSite = newSite, yedApp = middleware app }
|
||||
@ -465,7 +383,7 @@ testModifySite newSiteFn = do
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > import qualified Web.Cookie as Cookie
|
||||
-- > import qualified Data.Cookie as Cookie
|
||||
-- > :set -XOverloadedStrings
|
||||
-- > testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "name" }
|
||||
--
|
||||
@ -503,8 +421,7 @@ testClearCookies = do
|
||||
|
||||
-- Performs a given action using the last response. Use this to create
|
||||
-- response-level assertions
|
||||
withResponse' :: HasCallStack
|
||||
=> (state -> Maybe SResponse)
|
||||
withResponse' :: (state -> Maybe SResponse)
|
||||
-> [T.Text]
|
||||
-> (SResponse -> SIO state a)
|
||||
-> SIO state a
|
||||
@ -518,7 +435,7 @@ withResponse' getter errTrace f = maybe err f . getter =<< getSIO
|
||||
|
||||
-- | Performs a given action using the last response. Use this to create
|
||||
-- response-level assertions
|
||||
withResponse :: HasCallStack => (SResponse -> YesodExample site a) -> YesodExample site a
|
||||
withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a
|
||||
withResponse = withResponse' yedResponse []
|
||||
|
||||
-- | Use HXT to parse a value from an HTML tag.
|
||||
@ -527,8 +444,7 @@ parseHTML :: HtmlLBS -> Cursor
|
||||
parseHTML html = fromDocument $ HD.parseLBS html
|
||||
|
||||
-- | Query the last response using CSS selectors, returns a list of matched fragments
|
||||
htmlQuery' :: HasCallStack
|
||||
=> (state -> Maybe SResponse)
|
||||
htmlQuery' :: (state -> Maybe SResponse)
|
||||
-> [T.Text]
|
||||
-> Query
|
||||
-> SIO state [HtmlLBS]
|
||||
@ -538,22 +454,24 @@ htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQu
|
||||
Right matches -> return $ map (encodeUtf8 . TL.pack) matches
|
||||
|
||||
-- | Query the last response using CSS selectors, returns a list of matched fragments
|
||||
htmlQuery :: HasCallStack => Query -> YesodExample site [HtmlLBS]
|
||||
htmlQuery :: Query -> YesodExample site [HtmlLBS]
|
||||
htmlQuery = htmlQuery' yedResponse []
|
||||
|
||||
-- | Asserts that the two given values are equal.
|
||||
--
|
||||
-- In case they are not equal, the error message includes the two values.
|
||||
-- In case they are not equal, error message includes the two values.
|
||||
--
|
||||
-- @since 1.5.2
|
||||
assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
|
||||
assertEq m a b =
|
||||
liftIO $ HUnit.assertEqual msg a b
|
||||
where msg = "Assertion: " ++ m ++ "\n"
|
||||
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, the error message includes the values.
|
||||
-- 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 ()
|
||||
@ -573,38 +491,14 @@ assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample si
|
||||
assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b)
|
||||
|
||||
-- | Assert the last response status is as expected.
|
||||
-- If the status code doesn't match, a portion of the body is also printed to aid in debugging.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > get HomeR
|
||||
-- > statusIs 200
|
||||
statusIs :: HasCallStack => Int -> YesodExample site ()
|
||||
statusIs number = do
|
||||
withResponse $ \(SResponse status headers body) -> do
|
||||
let mContentType = lookup hContentType headers
|
||||
isUTF8ContentType = maybe False contentTypeHeaderIsUtf8 mContentType
|
||||
|
||||
liftIO $ flip HUnit.assertBool (H.statusCode status == number) $ concat
|
||||
[ "Expected status was ", show number
|
||||
, " but received status was ", show $ H.statusCode status
|
||||
, if isUTF8ContentType
|
||||
then ". For debugging, the body was: " <> (T.unpack $ getBodyTextPreview body)
|
||||
else ""
|
||||
]
|
||||
statusIs number = withResponse $ \ SResponse { simpleStatus = s } ->
|
||||
liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat
|
||||
[ "Expected status was ", show number
|
||||
, " but received status was ", show $ H.statusCode s
|
||||
]
|
||||
|
||||
-- | Assert the given header key/value pair was returned.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||||
-- > get HomeR
|
||||
-- > assertHeader "key" "value"
|
||||
--
|
||||
-- > import qualified Data.CaseInsensitive as CI
|
||||
-- > import qualified Data.ByteString.Char8 as BS8
|
||||
-- > getHomeR
|
||||
-- > assertHeader (CI.mk (BS8.pack "key")) (BS8.pack "value")
|
||||
assertHeader :: HasCallStack => CI BS8.ByteString -> BS8.ByteString -> YesodExample site ()
|
||||
assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->
|
||||
case lookup header h of
|
||||
@ -625,17 +519,6 @@ assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->
|
||||
]
|
||||
|
||||
-- | Assert the given header was not included in the response.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||||
-- > get HomeR
|
||||
-- > assertNoHeader "key"
|
||||
--
|
||||
-- > import qualified Data.CaseInsensitive as CI
|
||||
-- > import qualified Data.ByteString.Char8 as BS8
|
||||
-- > getHomeR
|
||||
-- > assertNoHeader (CI.mk (BS8.pack "key"))
|
||||
assertNoHeader :: HasCallStack => CI BS8.ByteString -> YesodExample site ()
|
||||
assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->
|
||||
case lookup header h of
|
||||
@ -649,11 +532,6 @@ assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->
|
||||
|
||||
-- | Assert the last response is exactly equal to the given text. This is
|
||||
-- useful for testing API responses.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > get HomeR
|
||||
-- > bodyEquals "<html><body><h1>Hello, World</h1></body></html>"
|
||||
bodyEquals :: HasCallStack => String -> YesodExample site ()
|
||||
bodyEquals text = withResponse $ \ res -> do
|
||||
let actual = simpleBody res
|
||||
@ -666,11 +544,6 @@ bodyEquals text = withResponse $ \ res -> do
|
||||
|
||||
-- | Assert the last response has the given text. The check is performed using the response
|
||||
-- body in full text form.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > get HomeR
|
||||
-- > bodyContains "<h1>Foo</h1>"
|
||||
bodyContains :: HasCallStack => String -> YesodExample site ()
|
||||
bodyContains text = withResponse $ \ res ->
|
||||
liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $
|
||||
@ -678,12 +551,6 @@ 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.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > get HomeR
|
||||
-- > bodyNotContains "<h1>Foo</h1>
|
||||
--
|
||||
-- @since 1.5.3
|
||||
bodyNotContains :: HasCallStack => String -> YesodExample site ()
|
||||
bodyNotContains text = withResponse $ \ res ->
|
||||
@ -695,74 +562,41 @@ 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.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||||
-- > get HomeR
|
||||
-- > htmlAllContain "p" "Hello" -- Every <p> tag contains the string "Hello"
|
||||
--
|
||||
-- > import qualified Data.Text as T
|
||||
-- > get HomeR
|
||||
-- > htmlAllContain (T.pack "h1#mainTitle") "Sign Up Now!" -- All <h1> tags with the ID mainTitle contain the string "Sign Up Now!"
|
||||
htmlAllContain :: HasCallStack => Query -> String -> YesodExample site ()
|
||||
htmlAllContain query search = do
|
||||
matches <- htmlQuery query
|
||||
case matches of
|
||||
[] -> failure $ "Nothing matched css query: " <> query
|
||||
_ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search ++ " matches: " ++ show matches) $
|
||||
DL.all (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
|
||||
|
||||
-- | puts the search trough the same escaping as the matches are.
|
||||
-- this helps with matching on special characters
|
||||
escape :: String -> String
|
||||
escape = Blaze.renderMarkup . Blaze.string
|
||||
_ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $
|
||||
DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
|
||||
|
||||
-- | Queries the HTML using a CSS selector, and passes if any matched
|
||||
-- element contains the given string.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||||
-- > get HomeR
|
||||
-- > htmlAnyContain "p" "Hello" -- At least one <p> tag contains the string "Hello"
|
||||
--
|
||||
-- Since 0.3.5
|
||||
htmlAnyContain :: HasCallStack => Query -> String -> YesodExample site ()
|
||||
htmlAnyContain query search = do
|
||||
matches <- htmlQuery query
|
||||
case matches of
|
||||
[] -> failure $ "Nothing matched css query: " <> query
|
||||
_ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search ++ " matches: " ++ show matches) $
|
||||
DL.any (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
|
||||
_ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search) $
|
||||
DL.any (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
|
||||
|
||||
-- | Queries the HTML using a CSS selector, and fails if any matched
|
||||
-- element contains the given string (in other words, it is the logical
|
||||
-- inverse of htmlAnyContain).
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||||
-- > get HomeR
|
||||
-- > htmlNoneContain ".my-class" "Hello" -- No tags with the class "my-class" contain the string "Hello"
|
||||
-- inverse of htmlAnyContains).
|
||||
--
|
||||
-- Since 1.2.2
|
||||
htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site ()
|
||||
htmlNoneContain query search = do
|
||||
matches <- htmlQuery query
|
||||
case DL.filter (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches) of
|
||||
case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of
|
||||
[] -> return ()
|
||||
found -> failure $ "Found " <> T.pack (show $ length found) <>
|
||||
" instances of " <> T.pack search <> " in " <> query <> " elements"
|
||||
|
||||
-- | Performs a CSS query on the last response and asserts the matched elements
|
||||
-- are as many as expected.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||||
-- > get HomeR
|
||||
-- > htmlCount "p" 3 -- There are exactly 3 <p> tags in the response
|
||||
htmlCount :: HasCallStack => Query -> Int -> YesodExample site ()
|
||||
htmlCount query count = do
|
||||
matches <- fmap DL.length $ htmlQuery query
|
||||
@ -791,45 +625,27 @@ requireJSONResponse = do
|
||||
isJSONContentType
|
||||
(failure $ T.pack $ "Expected `Content-Type: application/json` in the headers, got: " ++ show headers)
|
||||
case eitherDecode' body of
|
||||
Left err -> failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err, "JSON: ", getBodyTextPreview body]
|
||||
Left err -> do
|
||||
let characterLimit = 1024
|
||||
textBody = TL.toStrict $ decodeUtf8 body
|
||||
bodyPreview = if T.length textBody < characterLimit
|
||||
then textBody
|
||||
else T.take characterLimit textBody <> "... (use `printBody` to see complete response body)"
|
||||
failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err, "JSON: ", bodyPreview]
|
||||
Right v -> return v
|
||||
|
||||
-- | Outputs the last response body to stderr (So it doesn't get captured by HSpec). Useful for debugging.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > get HomeR
|
||||
-- > printBody
|
||||
-- | Outputs the last response body to stderr (So it doesn't get captured by HSpec)
|
||||
printBody :: YesodExample site ()
|
||||
printBody = withResponse $ \ SResponse { simpleBody = b } ->
|
||||
liftIO $ BSL8.hPutStrLn stderr b
|
||||
|
||||
-- | Performs a CSS query and print the matches to stderr.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||||
-- > get HomeR
|
||||
-- > printMatches "h1" -- Prints all h1 tags
|
||||
printMatches :: HasCallStack => Query -> YesodExample site ()
|
||||
printMatches :: Query -> YesodExample site ()
|
||||
printMatches query = do
|
||||
matches <- htmlQuery query
|
||||
liftIO $ hPutStrLn stderr $ show matches
|
||||
|
||||
-- | Add a parameter with the given name and value to the request body.
|
||||
-- This function can be called multiple times to add multiple parameters, and be mixed with calls to 'addFile'.
|
||||
--
|
||||
-- "Post parameter" is an informal description of what is submitted by making an HTTP POST with an HTML @\<form\>@.
|
||||
-- Like HTML @\<form\>@s, yesod-test will default to a @Content-Type@ of @application/x-www-form-urlencoded@ if no files are added,
|
||||
-- and switch to @multipart/form-data@ if files are added.
|
||||
--
|
||||
-- Calling this function after using 'setRequestBody' will raise an error.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||||
-- > post $ do
|
||||
-- > addPostParam "key" "value"
|
||||
addPostParam :: T.Text -> T.Text -> RequestBuilder site ()
|
||||
addPostParam name value =
|
||||
modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }
|
||||
@ -838,35 +654,12 @@ addPostParam name value =
|
||||
MultipleItemsPostData $ ReqKvPart name value : posts
|
||||
|
||||
-- | Add a parameter with the given name and value to the query string.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||||
-- > request $ do
|
||||
-- > addGetParam "key" "value" -- Adds ?key=value to the URL
|
||||
addGetParam :: T.Text -> T.Text -> RequestBuilder site ()
|
||||
addGetParam name value = modifySIO $ \rbd -> rbd
|
||||
{ rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)
|
||||
: rbdGets rbd
|
||||
}
|
||||
|
||||
-- | Add a bare parameter with the given name and no value to the query
|
||||
-- string. The parameter is added without an @=@ sign.
|
||||
--
|
||||
-- You can specify the entire query string literally by adding a single bare
|
||||
-- parameter and no other parameters.
|
||||
--
|
||||
-- @since 1.6.16
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- > {-# LANGUAGE OverloadedStrings #-}
|
||||
-- > request $ do
|
||||
-- > addBareGetParam "key" -- Adds ?key to the URL
|
||||
addBareGetParam :: T.Text -> RequestBuilder site ()
|
||||
addBareGetParam name = modifySIO $ \rbd ->
|
||||
rbd {rbdGets = (TE.encodeUtf8 name, Nothing) : rbdGets rbd}
|
||||
|
||||
-- | Add a file to be posted with the current request.
|
||||
--
|
||||
-- Adding a file will automatically change your request content-type to be multipart/form-data.
|
||||
@ -888,43 +681,16 @@ addFile name path mimetype = do
|
||||
|
||||
-- |
|
||||
-- This looks up the name of a field based on the contents of the label pointing to it.
|
||||
genericNameFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
|
||||
genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
|
||||
genericNameFromLabel match label = do
|
||||
mres <- fmap rbdResponse getSIO
|
||||
res <-
|
||||
case mres of
|
||||
Nothing -> failure "genericNameFromLabel: No response available"
|
||||
Just res -> return res
|
||||
let body = simpleBody res
|
||||
case genericNameFromHTML match label body of
|
||||
Left e -> failure e
|
||||
Right x -> pure x
|
||||
|
||||
-- |
|
||||
-- This looks up the name of a field based on a CSS selector and the contents of the label pointing to it.
|
||||
genericNameFromSelectorLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> T.Text -> RequestBuilder site T.Text
|
||||
genericNameFromSelectorLabel match selector label = do
|
||||
mres <- fmap rbdResponse getSIO
|
||||
res <-
|
||||
case mres of
|
||||
Nothing -> failure "genericNameSelectorFromLabel: No response available"
|
||||
Just res -> return res
|
||||
let body = simpleBody res
|
||||
html <-
|
||||
case findBySelector body selector of
|
||||
Left parseError -> failure $ "genericNameFromSelectorLabel: Parse error" <> T.pack parseError
|
||||
Right [] -> failure $ "genericNameFromSelectorLabel: No fragments match selector " <> selector
|
||||
Right [matchingFragment] -> pure $ BSL8.pack matchingFragment
|
||||
Right _matchingFragments -> failure $ "genericNameFromSelectorLabel: Multiple fragments match selector " <> selector
|
||||
case genericNameFromHTML match label html of
|
||||
Left e -> failure e
|
||||
Right x -> pure x
|
||||
|
||||
genericNameFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text
|
||||
genericNameFromHTML match label html =
|
||||
let
|
||||
parsedHTML = parseHTML html
|
||||
mlabel = parsedHTML
|
||||
body = simpleBody res
|
||||
mlabel = parseHTML body
|
||||
$// C.element "label"
|
||||
>=> isContentMatch label
|
||||
mfor = mlabel >>= attribute "for"
|
||||
@ -933,26 +699,26 @@ genericNameFromHTML match label html =
|
||||
| x `match` T.concat (c $// content) = [c]
|
||||
| otherwise = []
|
||||
|
||||
in case mfor of
|
||||
case mfor of
|
||||
for:[] -> do
|
||||
let mname = parsedHTML
|
||||
let mname = parseHTML body
|
||||
$// attributeIs "id" for
|
||||
>=> attribute "name"
|
||||
case mname of
|
||||
"":_ -> Left $ T.concat
|
||||
"":_ -> failure $ T.concat
|
||||
[ "Label "
|
||||
, label
|
||||
, " resolved to id "
|
||||
, for
|
||||
, " which was not found. "
|
||||
]
|
||||
name:_ -> Right name
|
||||
[] -> Left $ "No input with id " <> for
|
||||
name:_ -> return name
|
||||
[] -> failure $ "No input with id " <> for
|
||||
[] ->
|
||||
case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of
|
||||
[] -> Left $ "No label contained: " <> label
|
||||
name:_ -> Right name
|
||||
_ -> Left $ "More than one label contained " <> label
|
||||
[] -> failure $ "No label contained: " <> label
|
||||
name:_ -> return name
|
||||
_ -> failure $ "More than one label contained " <> label
|
||||
|
||||
byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
|
||||
-> T.Text -- ^ The text contained in the @\<label>@.
|
||||
@ -962,15 +728,6 @@ byLabelWithMatch match label value = do
|
||||
name <- genericNameFromLabel match label
|
||||
addPostParam name value
|
||||
|
||||
bySelectorLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
|
||||
-> T.Text -- ^ The CSS selector.
|
||||
-> T.Text -- ^ The text contained in the @\<label>@.
|
||||
-> T.Text -- ^ The value to set the parameter to.
|
||||
-> RequestBuilder site ()
|
||||
bySelectorLabelWithMatch match selector label value = do
|
||||
name <- genericNameFromSelectorLabel match selector label
|
||||
addPostParam name value
|
||||
|
||||
-- How does this work for the alternate <label><input></label> syntax?
|
||||
|
||||
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter
|
||||
@ -1084,18 +841,6 @@ byLabelSuffix :: T.Text -- ^ The text in the @\<label>@.
|
||||
-> RequestBuilder site ()
|
||||
byLabelSuffix = byLabelWithMatch T.isSuffixOf
|
||||
|
||||
-- |
|
||||
-- Note: This function throws an error if it finds multiple labels or if the
|
||||
-- CSS selector fails to parse, doesn't match any fragment, or matches multiple
|
||||
-- fragments.
|
||||
--
|
||||
-- @since 1.6.15
|
||||
bySelectorLabelContain :: T.Text -- ^ The CSS selector.
|
||||
-> T.Text -- ^ The text in the @\<label>@.
|
||||
-> T.Text -- ^ The value to set the parameter to.
|
||||
-> RequestBuilder site ()
|
||||
bySelectorLabelContain = bySelectorLabelWithMatch T.isInfixOf
|
||||
|
||||
fileByLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
|
||||
-> T.Text -- ^ The text contained in the @\<label>@.
|
||||
-> FilePath -- ^ The path to the file.
|
||||
@ -1208,7 +953,7 @@ fileByLabelSuffix = fileByLabelWithMatch T.isSuffixOf
|
||||
--
|
||||
-- > request $ do
|
||||
-- > addToken_ "#formID"
|
||||
addToken_ :: HasCallStack => Query -> RequestBuilder site ()
|
||||
addToken_ :: Query -> RequestBuilder site ()
|
||||
addToken_ scope = do
|
||||
matches <- htmlQuery' rbdResponse ["Tried to get CSRF token with addToken'"] $ scope <> " input[name=_token][type=hidden][value]"
|
||||
case matches of
|
||||
@ -1222,7 +967,7 @@ addToken_ scope = do
|
||||
--
|
||||
-- > request $ do
|
||||
-- > addToken
|
||||
addToken :: HasCallStack => RequestBuilder site ()
|
||||
addToken :: RequestBuilder site ()
|
||||
addToken = addToken_ ""
|
||||
|
||||
-- | Calls 'addTokenFromCookieNamedToHeaderNamed' with the 'defaultCsrfCookieName' and 'defaultCsrfHeaderName'.
|
||||
@ -1235,7 +980,7 @@ addToken = addToken_ ""
|
||||
-- > addTokenFromCookie
|
||||
--
|
||||
-- Since 1.4.3.2
|
||||
addTokenFromCookie :: HasCallStack => RequestBuilder site ()
|
||||
addTokenFromCookie :: RequestBuilder site ()
|
||||
addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName defaultCsrfHeaderName
|
||||
|
||||
-- | Looks up the CSRF token stored in the cookie with the given name and adds it to the request headers. An error is thrown if the cookie can't be found.
|
||||
@ -1251,8 +996,7 @@ addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName
|
||||
-- > addTokenFromCookieNamedToHeaderNamed "cookieName" (CI "headerName")
|
||||
--
|
||||
-- Since 1.4.3.2
|
||||
addTokenFromCookieNamedToHeaderNamed :: HasCallStack
|
||||
=> ByteString -- ^ The name of the cookie
|
||||
addTokenFromCookieNamedToHeaderNamed :: ByteString -- ^ The name of the cookie
|
||||
-> CI ByteString -- ^ The name of the header
|
||||
-> RequestBuilder site ()
|
||||
addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
|
||||
@ -1275,7 +1019,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
|
||||
-- > liftIO $ putStrLn $ "Cookies are: " ++ show cookies
|
||||
--
|
||||
-- Since 1.4.3.2
|
||||
getRequestCookies :: HasCallStack => RequestBuilder site Cookies
|
||||
getRequestCookies :: RequestBuilder site Cookies
|
||||
getRequestCookies = do
|
||||
requestBuilderData <- getSIO
|
||||
headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
|
||||
@ -1436,8 +1180,8 @@ setUrl url' = do
|
||||
-- > get "/foobar"
|
||||
-- > clickOn "a#idofthelink"
|
||||
--
|
||||
-- @since 1.5.7
|
||||
clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site ()
|
||||
-- @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
|
||||
@ -1641,7 +1385,7 @@ parseSetCookies :: [H.Header] -> [Cookie.SetCookie]
|
||||
parseSetCookies headers = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ headers
|
||||
|
||||
-- Yes, just a shortcut
|
||||
failure :: (HasCallStack, MonadIO a) => T.Text -> a b
|
||||
failure :: (MonadIO a) => T.Text -> a b
|
||||
failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error ""
|
||||
|
||||
type TestApp site = (site, Middleware)
|
||||
@ -1665,3 +1409,27 @@ instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) whe
|
||||
return ())
|
||||
params
|
||||
($ ())
|
||||
|
||||
-- | State + IO
|
||||
--
|
||||
-- @since 1.6.0
|
||||
newtype SIO s a = SIO (ReaderT (IORef s) IO a)
|
||||
deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
|
||||
|
||||
getSIO :: SIO s s
|
||||
getSIO = SIO $ ReaderT readIORef
|
||||
|
||||
putSIO :: s -> SIO s ()
|
||||
putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
|
||||
|
||||
modifySIO :: (s -> s) -> SIO s ()
|
||||
modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
|
||||
|
||||
evalSIO :: SIO s a -> s -> IO a
|
||||
evalSIO (SIO (ReaderT f)) s = newIORef s >>= f
|
||||
|
||||
execSIO :: SIO s () -> s -> IO s
|
||||
execSIO (SIO (ReaderT f)) s = do
|
||||
ref <- newIORef s
|
||||
f ref
|
||||
readIORef ref
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user