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

.github/PULL_REQUEST_TEMPLATE.md

@@ -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_-->

CODE_OF_CONDUCT.md

@@ -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
+In the interest of fostering an open and welcoming environment, we as
-they were standing next to you.
+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
+## Our Standards
-project to others outside the project.
 
-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.

stack.yaml

@@ -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

yesod-auth/Yesod/Auth.hs

@@ -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

yesod-bin/ChangeLog.md

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

yesod-bin/Devel.hs

@@ -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:
 --

yesod-bin/yesod-bin.cabal

@@ -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

yesod-core/Yesod/Core/Unsafe.hs

@@ -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

yesod-form/Yesod/Form/MassInput.hs

@@ -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

yesod-test/ChangeLog.md

@@ -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)

yesod-test/Yesod/Test.hs

@@ -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
+genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
-nameFromLabel label = do
+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
+    isContentMatch x c
-        | x `T.isInfixOf` T.concat (c $// content) = [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
+byLabel = byLabelWithMatch T.isInfixOf
-  name <- nameFromLabel label
+
-  addPostParam name value
+-- | 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.

yesod-test/test/main.hs

@@ -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

yesod-test/yesod-test.cabal

@@ -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>