haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into better-monads

Browse Source
This commit is contained in:
Michael Snoyman 2017-12-30 20:41:28 +02:00
commit 8a30e487b0
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
13 changed files with 233 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.github/PULL_REQUEST_TEMPLATE.md vendored
View File

@ -2,7 +2,7 @@ Before submitting your PR, check that you've:
- [ ] Bumped the version number
- [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html)
- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock
- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddocks for new, public APIs
After submitting your PR:
@ -11,4 +11,4 @@ After submitting your PR:
<!---Thanks so much for contributing! :)
_If these checkboxes don't apply to your PR, you can delete them_-->
_If these checkboxes don't apply to your PR, you can delete them_-->

77
CODE_OF_CONDUCT.md
View File

@ -1,13 +1,74 @@
# Contributor Code of Conduct
# Contributor Covenant Code of Conduct
Always be nice.
## Our Pledge
When communicating online treat people the way you would if
they were standing next to you.
In the interest of fostering an open and welcoming environment, we as
contributors and maintainers pledge to making participation in our project and
our community a harassment-free experience for everyone, regardless of age, body
size, disability, ethnicity, gender identity and expression, level of experience,
education, socio-economic status, nationality, personal appearance, race,
religion, or sexual identity and orientation.
Don't forget to be nice whenever representing the
project to others outside the project.
## Our Standards
If you are not nice, apologize.
Examples of behavior that contributes to creating a positive environment
include:
* Using welcoming and inclusive language
* Being respectful of differing viewpoints and experiences
* Gracefully accepting constructive criticism
* Focusing on what is best for the community
* Showing empathy towards other community members
Examples of unacceptable behavior by participants include:
* The use of sexualized language or imagery and unwelcome sexual attention or
advances
* Trolling, insulting/derogatory comments, and personal or political attacks
* Public or private harassment
* Publishing others' private information, such as a physical or electronic
address, without explicit permission
* Other conduct which could reasonably be considered inappropriate in a
professional setting
## Our Responsibilities
Project maintainers are responsible for clarifying the standards of acceptable
behavior and are expected to take appropriate and fair corrective action in
response to any instances of unacceptable behavior.
Project maintainers have the right and responsibility to remove, edit, or
reject comments, commits, code, wiki edits, issues, and other contributions
that are not aligned to this Code of Conduct, or to ban temporarily or
permanently any contributor for other behaviors that they deem inappropriate,
threatening, offensive, or harmful.
## Scope
This Code of Conduct applies both within project spaces and in public spaces
when an individual is representing the project or its community. Examples of
representing a project or community include using an official project e-mail
address, posting via an official social media account, or acting as an appointed
representative at an online or offline event. Representation of a project may be
further defined and clarified by project maintainers.
## Enforcement
Instances of abusive, harassing, or otherwise unacceptable behavior may be
reported by contacting the project team at `michael at snoyman dot com`. All
complaints will be reviewed and investigated and will result in a response that
is deemed necessary and appropriate to the circumstances. The project team is
obligated to maintain confidentiality with regard to the reporter of an incident.
Further details of specific enforcement policies may be posted separately.
Project maintainers who do not follow or enforce the Code of Conduct in good
faith may face temporary or permanent repercussions as determined by other
members of the project's leadership.
## Attribution
This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4,
available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html
[homepage]: https://www.contributor-covenant.org
If someone is not being nice, tell them in a respectful way or tell a project maintainer: we care about fostering a welcoming community.

2
stack.yaml
View File

@ -14,4 +14,6 @@ packages:
- ./yesod-eventsource
- ./yesod-websockets
extra-deps:
- conduit-extra-1.2.2
- unliftio-core-0.1.0.0
- typed-process-0.2.0.0

31
yesod-auth/Yesod/Auth.hs
View File

@ -85,7 +85,7 @@ type Piece = Text
-- | The result of an authentication based on credentials
--
-- Since 1.4.4
-- @since 1.4.4
data AuthenticationResult master
= Authenticated (AuthId master) -- ^ Authenticated successfully
| UserError AuthMessage -- ^ Invalid credentials provided by user
@ -126,7 +126,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
--
-- Default implementation is in terms of @'getAuthId'@
--
-- Since: 1.4.4
-- @since 1.4.4
authenticate :: Creds master -> HandlerT master IO (AuthenticationResult master)
authenticate creds = do
muid <- getAuthId creds
@ -184,7 +184,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- | When being redirected to the login page should the current page
-- be set to redirect back to. Default is 'True'.
-- @since 1.4.18
--
-- @since 1.4.21
redirectToCurrent :: master -> Bool
redirectToCurrent _ = True
@ -211,7 +212,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- especially useful for creating an API to be accessed via some means
-- other than a browser.
--
-- Since 1.2.0
-- @since 1.2.0
maybeAuthId :: HandlerT master IO (Maybe (AuthId master))
default maybeAuthId
@ -242,7 +243,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- | Internal session key used to hold the authentication information.
--
-- Since 1.2.3
-- @since 1.2.3
credsKey :: Text
credsKey = "_ID"
@ -252,7 +253,7 @@ credsKey = "_ID"
-- 'maybeAuthIdRaw' for more information. The first call in a request
-- does a database request to make sure that the account is still in the database.
--
-- Since 1.1.2
-- @since 1.1.2
defaultMaybeAuthId
:: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerT master IO (Maybe (AuthId master))
@ -277,7 +278,7 @@ cachedAuth
-- This is the default 'loginHandler'. It concatenates plugin widgets and
-- wraps the result in 'authLayout'. See 'loginHandler' for more details.
--
-- Since 1.4.9
-- @since 1.4.9
defaultLoginHandler :: AuthHandler master Html
defaultLoginHandler = do
tp <- getRouteToParent
@ -398,7 +399,7 @@ authLayoutJson w json = selectRep $ do
-- | Clears current user credentials for the session.
--
-- Since 1.1.7
-- @since 1.1.7
clearCreds :: YesodAuth master
=> Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-> HandlerT master IO ()
@ -457,7 +458,7 @@ handlePluginR plugin pieces = do
-- with the user\'s database identifier to get the value in the database. This
-- assumes that you are using a Persistent database.
--
-- Since 1.1.0
-- @since 1.1.0
maybeAuth :: ( YesodAuthPersist master
, val ~ AuthEntity master
, Key val ~ AuthId master
@ -471,7 +472,7 @@ maybeAuth = runMaybeT $ do
-- | Similar to 'maybeAuth', but doesn’t assume that you are using a
-- Persistent database.
--
-- Since 1.4.0
-- @since 1.4.0
maybeAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerT master IO (Maybe (AuthId master, AuthEntity master))
maybeAuthPair = runMaybeT $ do
@ -492,7 +493,7 @@ newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
-- given value. This is the common case in Yesod, and means that you can
-- easily look up the full information on a given user.
--
-- Since 1.4.0
-- @since 1.4.0
class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
-- | If the @AuthId@ for a given site is a persistent ID, this will give the
-- value for that entity. E.g.:
@ -500,7 +501,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
-- > type AuthId MySite = UserId
-- > AuthEntity MySite ~ User
--
-- Since 1.2.0
-- @since 1.2.0
type AuthEntity master :: *
type AuthEntity master = KeyEntity (AuthId master)
@ -533,14 +534,14 @@ type instance KeyEntity (Key x) = x
-- | Similar to 'maybeAuthId', but redirects to a login page if user is not
-- authenticated or responds with error 401 if this is an API client (expecting JSON).
--
-- Since 1.1.0
-- @since 1.1.0
requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master)
requireAuthId = maybeAuthId >>= maybe handleAuthLack return
-- | Similar to 'maybeAuth', but redirects to a login page if user is not
-- authenticated or responds with error 401 if this is an API client (expecting JSON).
--
-- Since 1.1.0
-- @since 1.1.0
requireAuth :: ( YesodAuthPersist master
, val ~ AuthEntity master
, Key val ~ AuthId master
@ -552,7 +553,7 @@ requireAuth = maybeAuth >>= maybe handleAuthLack return
-- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
-- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple.
--
-- Since 1.4.0
-- @since 1.4.0
requireAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerT master IO (AuthId master, AuthEntity master)
requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return

4
yesod-bin/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.5.3
* Support typed-process-0.2.0.0
## 1.5.2.6
* Drop an upper bound

2
yesod-bin/Devel.hs
View File

@ -61,7 +61,7 @@ import System.FilePath (takeDirectory,
import System.FSNotify
import System.IO (stdout, stderr)
import System.IO.Error (isDoesNotExistError)
import System.Process.Typed
import Data.Conduit.Process.Typed
-- We have two special files:
--

5
yesod-bin/yesod-bin.cabal
View File

@ -1,5 +1,5 @@
name: yesod-bin
version: 1.5.2.6
version: 1.5.3
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -49,7 +49,7 @@ executable yesod
, split >= 0.2 && < 0.3
, file-embed
, conduit >= 1.2
, conduit-extra
, conduit-extra >= 1.2.2
, resourcet >= 0.3 && < 1.2
, base64-bytestring
, lifted-base
@ -71,7 +71,6 @@ executable yesod
, warp-tls >= 3.0.1
, async
, deepseq
, typed-process
ghc-options: -Wall -threaded -rtsopts
main-is: main.hs

2
yesod-core/Yesod/Core/Unsafe.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE CPP #-}
-- | This is designed to be used as
--
-- > qualified import Yesod.Core.Unsafe as Unsafe
-- > import qualified Yesod.Core.Unsafe as Unsafe
--
-- This serves as a reminder that the functions are unsafe to use in many situations.
module Yesod.Core.Unsafe (runFakeHandler, fakeHandlerGetLogger) where

2
yesod-form/Yesod/Form/MassInput.hs
View File

@ -2,7 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP#-}
{-# LANGUAGE CPP #-}
-- | A module providing a means of creating multiple input forms, such as a
-- list of 0 or more recipients.
module Yesod.Form.MassInput

8
yesod-test/ChangeLog.md
View File

@ -1,3 +1,11 @@
## 1.5.9.1
* Fixes a Haddock syntax error in 1.5.9 [#1473](https://github.com/yesodweb/yesod/pull/1473)
## 1.5.9
* Add byLabelExact and related functions
[#1459](https://github.com/yesodweb/yesod/pull/1459)
## 1.5.8
* Added implicit parameter HasCallStack to assertions.
[#1421](https://github.com/yesodweb/yesod/pull/1421)

115
yesod-test/Yesod/Test.hs
View File

@ -73,7 +73,9 @@ module Yesod.Test
-- These functions let you add parameters to your request based
-- on currently displayed label names.
, byLabel
, byLabelExact
, fileByLabel
, fileByLabelExact
-- *** CSRF Tokens
-- | In order to prevent CSRF exploits, yesod-form adds a hidden input
@ -162,6 +164,8 @@ import GHC.Exts (Constraint)
type HasCallStack = (() :: Constraint)
#endif
{-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact instead" #-}
{-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact instead" #-}
-- | The state used in a single test case defined using 'yit'
--
@ -523,23 +527,24 @@ addFile name path mimetype = do
addPostData (MultipleItemsPostData posts) contents =
MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts
-- |
-- This looks up the name of a field based on the contents of the label pointing to it.
nameFromLabel :: T.Text -> RequestBuilder site T.Text
nameFromLabel label = do
genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
genericNameFromLabel match label = do
mres <- fmap rbdResponse ST.get
res <-
case mres of
Nothing -> failure "nameFromLabel: No response available"
Nothing -> failure "genericNameFromLabel: No response available"
Just res -> return res
let
body = simpleBody res
mlabel = parseHTML body
$// C.element "label"
>=> contentContains label
>=> isContentMatch label
mfor = mlabel >>= attribute "for"
contentContains x c
| x `T.isInfixOf` T.concat (c $// content) = [c]
isContentMatch x c
| x `match` T.concat (c $// content) = [c]
| otherwise = []
case mfor of
@ -566,6 +571,14 @@ nameFromLabel label = do
(<>) :: T.Text -> T.Text -> T.Text
(<>) = T.append
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>@.
-> T.Text -- ^ The value to set the parameter to.
-> RequestBuilder site ()
byLabelWithMatch match label value = do
name <- genericNameFromLabel match 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
@ -591,12 +604,60 @@ nameFromLabel label = do
-- > <form method="POST">
-- > <label>Username <input name="f1"> </label>
-- > </form>
--
-- Warning: This function looks for any label that contains the provided text.
-- If multiple labels contain that text, this function will throw an error,
-- as in the example below:
--
-- > <form method="POST">
-- > <label for="nickname">Nickname</label>
-- > <input id="nickname" name="f1" />
--
-- > <label for="nickname2">Nickname2</label>
-- > <input id="nickname2" name="f2" />
-- > </form>
--
-- > request $ do
-- > byLabel "Nickname" "Snoyberger"
--
-- Then, it throws "More than one label contained" error.
--
-- Therefore, this function is deprecated. Please consider using 'byLabelExact',
-- which performs the exact match over the provided text.
byLabel :: T.Text -- ^ The text contained in the @\<label>@.
-> T.Text -- ^ The value to set the parameter to.
-> RequestBuilder site ()
byLabel label value = do
name <- nameFromLabel label
addPostParam name value
byLabel = byLabelWithMatch T.isInfixOf
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter
-- for that input to the request body.
--
-- ==== __Examples__
--
-- Given this HTML, we want to submit @f1=Michael@ to the server:
--
-- > <form method="POST">
-- > <label for="user">Username</label>
-- > <input id="user" name="f1" />
-- > </form>
--
-- You can set this parameter like so:
--
-- > request $ do
-- > byLabel "Username" "Michael"
--
-- This function also supports the implicit label syntax, in which
-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:
--
-- > <form method="POST">
-- > <label>Username <input name="f1"> </label>
-- > </form>
--
-- @since 1.5.9
byLabelExact :: T.Text -- ^ The text in the @\<label>@.
-> T.Text -- ^ The value to set the parameter to.
-> RequestBuilder site ()
byLabelExact = byLabelWithMatch (==)
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a file for that input to the request body.
--
@ -620,12 +681,46 @@ byLabel label value = do
-- > <form method="POST">
-- > <label>Please submit an image <input type="file" name="f1"> </label>
-- > </form>
--
-- Warning: This function has the same issue as 'byLabel'. Please use 'fileByLabelExact' instead.
fileByLabel :: T.Text -- ^ The text contained in the @\<label>@.
-> FilePath -- ^ The path to the file.
-> T.Text -- ^ The MIME type of the file, e.g. "image/png".
-> RequestBuilder site ()
fileByLabel label path mime = do
name <- nameFromLabel label
name <- genericNameFromLabel T.isInfixOf label
addFile name path mime
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a file for that input to the request body.
--
-- ==== __Examples__
--
-- Given this HTML, we want to submit a file with the parameter name @f1@ to the server:
--
-- > <form method="POST">
-- > <label for="imageInput">Please submit an image</label>
-- > <input id="imageInput" type="file" name="f1" accept="image/*">
-- > </form>
--
-- You can set this parameter like so:
--
-- > request $ do
-- > fileByLabel "Please submit an image" "static/img/picture.png" "img/png"
--
-- This function also supports the implicit label syntax, in which
-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:
--
-- > <form method="POST">
-- > <label>Please submit an image <input type="file" name="f1"> </label>
-- > </form>
--
-- @since 1.5.9
fileByLabelExact :: T.Text -- ^ The text contained in the @\<label>@.
-> FilePath -- ^ The path to the file.
-> T.Text -- ^ The MIME type of the file, e.g. "image/png".
-> RequestBuilder site ()
fileByLabelExact label path mime = do
name <- genericNameFromLabel (==) label
addFile name path mime
-- | Lookups the hidden input named "_token" and adds its value to the params.

21
yesod-test/test/main.hs
View File

@ -1,3 +1,6 @@
-- Ignore warnings about using deprecated byLabel/fileByLabel functions
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
@ -215,6 +218,22 @@ main = hspec $ do
setMethod "POST"
setUrl ("/labels" :: Text)
byLabel "Foo Bar" "yes"
ydescribe "labels2" $ do
yit "fails with \"More than one label contained\" error" $ do
get ("/labels2" :: Text)
(bad :: Either SomeException ()) <- try (request $ do
setMethod "POST"
setUrl ("labels2" :: Text)
byLabel "hobby" "fishing")
assertEq "failure wasn't called" (isLeft bad) True
yit "byLabelExact performs an exact match over the given label name" $ do
get ("/labels2" :: Text)
(bad :: Either SomeException ()) <- try (request $ do
setMethod "POST"
setUrl ("labels2" :: Text)
byLabelExact "hobby" "fishing")
assertEq "failure was called" (isRight bad) True
ydescribe "Content-Type handling" $ do
yit "can set a content-type" $ do
request $ do
@ -362,6 +381,8 @@ app = liteApp $ do
return ("<html><head><title>A link</title></head><body><a href=\"/html\" id=\"thelink\">Link!</a></body></html>" :: Text)
onStatic "labels" $ dispatchTo $
return ("<html><label><input type='checkbox' name='fooname' id='foobar'>Foo Bar</label></html>" :: Text)
onStatic "labels2" $ dispatchTo $
return ("<html><label for='hobby'>hobby</label><label for='hobby2'>hobby2</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)
onStatic "checkContentType" $ dispatchTo $ do
headers <- requestHeaders <$> waiRequest

2
yesod-test/yesod-test.cabal
View File

@ -1,5 +1,5 @@
name: yesod-test
version: 1.5.8
version: 1.5.9.1
license: MIT
license-file: LICENSE
author: Nubis <nubis@woobiz.com.ar>