merged master

.github/ISSUE_TEMPLATE.md

@@ -0,0 +1,29 @@
+<!---
+
+### Bug Reports
+
+Reporting a bug? If relevant, we recommend including:
+
+* Your OS name and version
+* The versions of tools you're using (e.g. `stack`, `yesod` `ghc`).
+* The versions of dependencies you're using
+
+For your convenience, we recommend pasting this script into bash and uploading the output [as a gist](https://gist.github.com/).
+
+```
+command -v sw_vers && sw_vers # OS X only
+command -v uname && uname -a # Kernel version
+command -v stack && stack --version
+command -v stack && stack ghc -- --version
+command -v stack && stack list-dependencies
+command -v yesod && yesod version
+```
+
+* Also, is there anything custom or unusual about your setup? i.e. new or prerelease versions of GHC, stack, etc.
+
+* Finally, if possible, please reproduce the error in a small script, or if necessary create a new Github repo with the smallest possible reproducing case. [Stack's scripting support](https://docs.haskellstack.org/en/stable/GUIDE/#script-interpreter) might be useful for creating your reproduction example.
+
+### Support
+
+Please direct support questions to [Stack Overflow](https://stackoverflow.com/questions/tagged/yesod+haskell) or the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb). If you don't get a response there, or you suspect there may be a bug in Yesod causing your problem, you're welcome to ask here.
+-->

.github/PULL_REQUEST_TEMPLATE.md

@@ -0,0 +1,14 @@
+Before submitting your PR, check that you've:
+
+- [ ] Bumped the version number
+- [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html)
+- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock
+
+After submitting your PR:
+
+- [ ] Update the Changelog.md file with a link to your PR
+- [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts)
+
+<!---Thanks so much for contributing! :)
+
+_If these checkboxes don't apply to your PR, you can delete them_-->

.travis.yml

@@ -53,9 +53,9 @@ matrix:
   - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7
     compiler: ": #GHC 7.10.3"
     addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
-  - env: BUILD=cabal GHCVER=8.0.1 CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
+  - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
-    compiler: ": #GHC 8.0.1"
+    compiler: ": #GHC 8.0.2"
-    addons: {apt: {packages: [cabal-install-head,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+    addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
 
   # Build with the newest GHC and cabal-install. This is an accepted failure,
   # see below.
@@ -69,20 +69,12 @@ matrix:
     compiler: ": #stack default"
     addons: {apt: {packages: [libgmp-dev]}}
 
-  - env: BUILD=stack ARGS="--resolver lts-2"
-    compiler: ": #stack 7.8.4"
-    addons: {apt: {packages: [libgmp-dev]}}
-
-  - env: BUILD=stack ARGS="--resolver lts-3"
-    compiler: ": #stack 7.10.2"
-    addons: {apt: {packages: [libgmp-dev]}}
-
   - env: BUILD=stack ARGS="--resolver lts-6"
     compiler: ": #stack 7.10.3"
     addons: {apt: {packages: [libgmp-dev]}}
 
-  - env: BUILD=stack ARGS="--resolver lts-7"
+  - env: BUILD=stack ARGS="--resolver lts-8"
-    compiler: ": #stack 8.0.1"
+    compiler: ": #stack 8.0.2"
     addons: {apt: {packages: [libgmp-dev]}}
 
   # Nightly builds are allowed to fail
@@ -95,21 +87,12 @@ matrix:
     compiler: ": #stack default osx"
     os: osx
 
-  # Travis includes an OS X which is incompatible with GHC 7.8.4
-  #- env: BUILD=stack ARGS="--resolver lts-2"
-  #  compiler: ": #stack 7.8.4 osx"
-  #  os: osx
-
-  - env: BUILD=stack ARGS="--resolver lts-3"
-    compiler: ": #stack 7.10.2 osx"
-    os: osx
-
   - env: BUILD=stack ARGS="--resolver lts-6"
     compiler: ": #stack 7.10.3 osx"
     os: osx
 
-  - env: BUILD=stack ARGS="--resolver lts-7"
+  - env: BUILD=stack ARGS="--resolver lts-8"
-    compiler: ": #stack 8.0.1 osx"
+    compiler: ": #stack 8.0.2 osx"
     os: osx
 
   - env: BUILD=stack ARGS="--resolver nightly"
@@ -119,6 +102,8 @@ matrix:
   allow_failures:
   - env: BUILD=cabal GHCVER=head  CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
   - env: BUILD=stack ARGS="--resolver nightly"
+  - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7
+  - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7
 
 before_install:
 # Using compiler above sets CC to an invalid value, so unset it
@@ -154,9 +139,10 @@ install:
 - if [ -f configure.ac ]; then autoreconf -i; fi
 - |
   set -ex
-  if [ "$RESOLVER" = "--resolver nightly" ]
+  if [ "$ARGS" = "--resolver nightly" ]
   then
-    stack $RESOLVER solver --update-config
+    stack --install-ghc $ARGS build cabal-install
+    stack --install-ghc $ARGS solver --update-config
   fi
   set +ex
 
@@ -170,10 +156,16 @@ script:
         # Build dependencies with -O0 as well
         echo "apply-ghc-options: everything" >> stack.yaml
 
+        # Avoid OOM for building Cabal
+        stack --install-ghc --no-terminal $ARGS build Cabal --fast
+
         # Use slightly less intensive options on OS X due to Travis timeouts
-        stack --no-terminal $ARGS test --fast --pedantic
+        stack --install-ghc --no-terminal $ARGS test --fast
       else
-        stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --pedantic
+        # Avoid OOM for building Cabal
+        stack --install-ghc --no-terminal $ARGS build Cabal --fast
+
+        stack --install-ghc --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --pedantic
       fi
       ;;
     cabal)

CONTRIBUTING.md

@@ -0,0 +1,95 @@
+# Contributing
+
+Thanks for your interest in contributing to Yesod! This file has some tips for developing Yesod and getting a pull request accepted.
+
+## Development
+
+Yesod is a mega-repo that contains many Haskell packages, each in a different directory. All the subprojects can be developed with Stack, using `stack <command> <subproject>`, e.g.
+
+* `stack build yesod-form`
+* `stack test yesod-auth`
+* `stack haddock yesod-websockets`
+
+If you'd like to test your changes in a full-fledged Yesod app, you can use Stack to build against it, e.g.:
+
+```
+packages:
+- '/path/to/this/repo/yesod-auth'
+```
+
+## Coding Guidelines
+
+### Safety
+
+Avoid partial functions. Even if you know the partial function is safe in your instance, partial functions require more reasoning from the programmer and are not resilient to refactoring. For the rare cases where a partial function is appropriate, a custom `error` should be used.
+
+### Style 
+
+Keep coding style consistent with the rest of the file, but don't worry about style too much otherwise. PRs changing code style are viewed skeptically.
+
+### Dependencies
+
+Avoid adding unnecessary dependencies. If a dependency provides only a minor convenience for your implementation, it's probably better to skip it.
+
+If you do add a new dependency, try to support a wide range of versions of it.
+
+### Backwards Compatibility
+
+Backwards incompatible changes are viewed skeptically—best to ask in an issue to see if a particular backwards incompatible change would be approved. If possible keep backwards compatibility by adding new APIs and deprecating old ones.
+
+Keep backwards compatibility with old versions of dependencies when possible.
+
+## PR Guidelines
+
+### PR Scope
+
+As much as possible, keep separate changes in separate PRs.
+
+### Testing
+
+Tests are recommended, but not required.
+
+### Documentation
+
+All public APIs must be documented. Documenting private functions is optional, but may be nice depending on their complexity. Example documentation:
+
+```
+-- | Looks up the hidden input named "_token" and adds its value to the params.
+--
+-- ==== __Examples__
+--
+-- > request $ do
+-- >   addToken_ "#formID"
+--
+-- @since 1.5.4
+addToken_ :: Query -- ^ CSS selector that resolves to the @<form>@ containing the token.
+		  -> RequestBuilder site ()
+```
+
+Examples are recommended, but not required, in documentation. Marking new APIs with `@since <version number>` is required.
+
+### Versioning
+
+Yesod packages roughly follow the Haskell Package Versioning Policy style of A.B.C.[D] (MAJOR.MAJOR.MINOR.[PATCH])
+
+* A - Used for massive changes in the library. (Example: 1.2.3.4 becomes 2.0.0)
+* B - Used for smaller breaking changes, like removing, renaming, or changing behavior of existing public API. (Example: 1.2.3.4 becomes 1.3.0)
+* C - Used for new public APIs (Example: 1.2.3.4 becomes 1.2.4)
+* D - Used for bug fixes (Example: 1.2.3.4 becomes 1.2.3.5).
+	* D is optional in the version number, so 2.0.0 is a valid version.
+
+Documentation changes don't require a new version.
+
+If you feel there is ambiguity to a change (e.g. fixing a bug in a function, when people may be relying on the old broken behavior), you can ask in an issue or pull request.
+
+Unlike in the Package Versioning Policy, deprecations are not counted as MAJOR changes.
+
+In some cases, dropping compatibility with a major version of a dependency (e.g. changing from transformers >= 0.3 to transformers >= 0.4), is considered a breaking change.
+
+### Changelog
+
+After you submit a PR, update the subproject's Changelog.md file with the new version number and a link to your PR. If your PR does not need to bump the version number, include the change in an "Unreleased" section at the top.
+
+### Releases
+
+Releases should be done as soon as possible after a pull request is merged—don't be shy about reminding us to make a release if we forget.

LICENSE

@@ -1,4 +1,4 @@
-Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+Copyright (c) 2012-2017 Michael Snoyman, http://www.yesodweb.com/
 
 Permission is hereby granted, free of charge, to any person obtaining
 a copy of this software and associated documentation files (the

appveyor.yml

@@ -1,6 +1,9 @@
 build: off
 
 before_test:
+# http://help.appveyor.com/discussions/problems/6312-curl-command-not-found
+- set PATH=C:\Program Files\Git\mingw64\bin;%PATH%
+
 - curl -sS -ostack.zip -L --insecure http://www.stackage.org/stack/windows-i386
 - 7z x stack.zip stack.exe
 

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-6.23
+resolver: lts-8.12
 packages:
   - ./yesod-core
   - ./yesod-static
@@ -13,20 +13,3 @@ packages:
   - ./yesod
   - ./yesod-eventsource
   - ./yesod-websockets
-
-# Needed for LTS 2
-extra-deps:
-- wai-app-static-3.1.4.1
-- http-api-data-0.2
-- yaml-0.8.17
-- nonce-1.0.2
-- persistent-2.5
-- persistent-sqlite-2.5
-- cookie-0.4.2
-
-- conduit-extra-1.1.14
-- streaming-commons-0.1.16
-- typed-process-0.1.0.0
-- say-0.1.0.0
-- safe-exceptions-0.1.4.0
-- blaze-markup-0.7.1.0

yesod-auth-oauth/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.4.2
+
+* Fix warnings
+
 ## 1.4.1
 
 * change OAuth Twitter ID, screen_name → user_id [#1168](https://github.com/yesodweb/yesod/pull/1168)

yesod-auth-oauth/yesod-auth-oauth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth-oauth
-version:         1.4.1.1
+version:         1.4.2
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
@@ -21,7 +21,7 @@ library
         cpp-options:     -DGHC7
     else
         build-depends:   base                >= 4         && < 4.3
-    build-depends:   authenticate-oauth      >= 1.5       && < 1.6
+    build-depends:   authenticate-oauth      >= 1.5       && < 1.7
                    , bytestring              >= 0.9.1.4
                    , yesod-core              >= 1.4       && < 1.5
                    , yesod-auth              >= 1.4       && < 1.5

yesod-auth/ChangeLog.md

@@ -1,11 +1,38 @@
-## 1.4.18
+## 1.4.21
 
 * Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin
 
+## 1.4.20
+
+* Extend `YesodAuthEmail` to support extensible password hashing via
+  `hashAndSaltPassword` and `verifyPassword` functions
+
+## 1.4.19
+
+* Adjust English localization to distinguish between "log in" (verb) and "login" (noun)
+
+## 1.4.18
+
+* Expose Yesod.Auth.Util.PasswordStore
+
+## 1.4.17.3
+
+* Some translation fixes
+
+## 1.4.17.2
+
+* Move to cryptonite from cryptohash
+
+## 1.4.17.1
+
+* Some translation fixes
+
 ## 1.4.17
 
 * Add Show instance for user credentials `Creds`
 * Export pid type for identifying plugin
+* Fix warnings
+* Allow for a custom Email Login DOM with `emailLoginHandler`
 
 ## 1.4.16
 

yesod-auth/Yesod/Auth.hs

@@ -249,7 +249,8 @@ credsKey = "_ID"
 -- | Retrieves user credentials from the session, if user is authenticated.
 --
 -- This function does /not/ confirm that the credentials are valid, see
--- 'maybeAuthIdRaw' for more information.
+-- 'maybeAuthIdRaw' for more information. The first call in a request
+-- does a database request to make sure that the account is still in the database.
 --
 -- Since 1.1.2
 defaultMaybeAuthId

yesod-auth/Yesod/Auth/Email.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE PatternGuards           #-}
 {-# LANGUAGE QuasiQuotes             #-}
 {-# LANGUAGE Rank2Types              #-}
-{-# LANGUAGE ScopedTypeVariables#-}
+{-# LANGUAGE ScopedTypeVariables     #-}
 {-# LANGUAGE TypeFamilies            #-}
 -- | A Yesod plugin for Authentication via e-mail
 --
@@ -106,6 +106,7 @@ module Yesod.Auth.Email
     , loginLinkKey
     , setLoginLinkKey
      -- * Default handlers
+    , defaultEmailLoginHandler
     , defaultRegisterHandler
     , defaultForgotPasswordHandler
     , defaultSetPasswordHandler
@@ -115,10 +116,9 @@ import           Yesod.Auth
 import qualified Yesod.Auth.Message       as Msg
 import           Yesod.Core
 import           Yesod.Form
-import qualified Yesod.PasswordStore      as PS
+import qualified Yesod.Auth.Util.PasswordStore as PS
-
 import           Control.Applicative      ((<$>), (<*>))
-import qualified Crypto.Hash.MD5          as H
+import qualified Crypto.Hash              as H
 import qualified Crypto.Nonce             as Nonce
 import           Data.ByteString.Base16   as B16
 import           Data.Text                (Text)
@@ -132,7 +132,8 @@ import           Safe                     (readMay)
 import           System.IO.Unsafe         (unsafePerformIO)
 import qualified Text.Email.Validate
 import           Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
-import           Data.Maybe (isJust, isNothing, fromJust)
+import           Data.Maybe (isJust)
+import Data.ByteArray (convert)
 
 loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
 loginR = PluginR "email" ["login"]
@@ -202,6 +203,22 @@ class ( YesodAuth site
     -- @since 1.1.0
     setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO ()
 
+    -- | Hash and salt a password
+    --
+    -- Default: 'saltPass'.
+    --
+    -- @since 1.4.20
+    hashAndSaltPassword :: Text -> HandlerT site IO SaltedPass
+    hashAndSaltPassword = liftIO . saltPass
+
+    -- | Verify a password matches the stored password for the given account.
+    --
+    -- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'.
+    --
+    -- @since 1.4.20
+    verifyPassword :: Text -> SaltedPass -> HandlerT site IO Bool
+    verifyPassword plain salted = return $ isValidPass plain salted
+
     -- | Verify the email address on the given account.
     --
     -- __/Warning!/__ If you have persisted the @'AuthEmailId' site@
@@ -290,6 +307,17 @@ class ( YesodAuth site
     normalizeEmailAddress :: site -> Text -> Text
     normalizeEmailAddress _ = TS.toLower
 
+    -- | Handler called to render the login page.
+    -- The default works fine, but you may want to override it in
+    -- order to have a different DOM.
+    --
+    -- Default: 'defaultEmailLoginHandler'.
+    --
+    -- @since 1.4.17
+    emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO ()
+    emailLoginHandler = defaultEmailLoginHandler
+
+
     -- | Handler called to render the registration page.  The
     -- default works fine, but you may want to override it in
     -- order to have a different DOM.
@@ -346,8 +374,11 @@ authEmail =
 getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
 getRegisterR = registerHandler
 
-emailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO ()
+-- | Default implementation of 'emailLoginHandler'.
-emailLoginHandler toParent = do
+--
+-- @since 1.4.17
+defaultEmailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO ()
+defaultEmailLoginHandler toParent = do
         (widget, enctype) <- liftWidgetT $ generateFormPost loginForm
 
         [whamlet|
@@ -402,6 +433,7 @@ emailLoginHandler toParent = do
         langs <- languages
         master <- getYesod
         return $ renderAuthMessage master langs msg
+
 -- | Default implementation of 'registerHandler'.
 --
 -- @since 1.2.6
@@ -518,7 +550,7 @@ defaultForgotPasswordHandler = do
   where
     forgotPasswordForm extra = do
         (emailRes, emailView) <- mreq emailField emailSettings Nothing
-    
+
         let forgotPasswordRes = ForgotPasswordForm <$> emailRes
         let widget = do
             [whamlet|
@@ -604,12 +636,14 @@ postLoginR = do
                    , emailCredsStatus <$> mecreds
                    ) of
                 (Just aid, Just email', Just True) -> do
-                       mrealpass <- lift $ getPassword aid
+                      mrealpass <- lift $ getPassword aid
-                       case mrealpass of
+                      case mrealpass of
-                         Nothing -> return Nothing
+                        Nothing -> return Nothing
-                         Just realpass -> return $ if isValidPass pass realpass
+                        Just realpass -> do
-                                                   then Just email'
+                            passValid <- lift $ verifyPassword pass realpass 
-                                                   else Nothing
+                            return $ if passValid
+                                    then Just email'
+                                    else Nothing
                 _ -> return Nothing
           let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
           case maid of
@@ -737,14 +771,16 @@ postPasswordR = do
                               then getThird jcreds
                               else fcurrent
                 mrealpass <- lift $ getPassword aid
-                case mrealpass of
+                case (mrealpass, current) of
-                    Nothing ->
+                    (Nothing, _) ->
                         lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
-                    Just realpass
+                    (_, Nothing) ->
-                        | isNothing current -> loginErrorMessageI LoginR Msg.BadSetPass
+                        loginErrorMessageI LoginR Msg.BadSetPass
-                        | isValidPass (fromJust current) realpass -> confirmPassword aid tm jcreds
+                    (Just realpass, Just current') -> do
-                        | otherwise ->
+                        passValid <- lift $ verifyPassword current' realpass
-                            lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
+                        if passValid
+                          then confirmPassword aid tm jcreds
+                          else lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
 
   where
     msgOk = Msg.PassUpdated
@@ -771,7 +807,7 @@ postPasswordR = do
                 case isSecure of
                   Left e -> lift $ loginErrorMessage (tm setpassR) e
                   Right () -> do
-                     salted <- liftIO $ saltPass new
+                     salted <- lift $ hashAndSaltPassword new
                      y <- lift $ do
                                 setPassword aid salted
                                 deleteSession loginLinkKey
@@ -795,7 +831,7 @@ saltPass = fmap (decodeUtf8With lenientDecode)
 
 saltPass' :: String -> String -> String
 saltPass' salt pass =
-    salt ++ T.unpack (TE.decodeUtf8 $ B16.encode $ H.hash $ TE.encodeUtf8 $ T.pack $ salt ++ pass)
+    salt ++ T.unpack (TE.decodeUtf8 $ B16.encode $ convert (H.hash (TE.encodeUtf8 $ T.pack $ salt ++ pass) :: H.Digest H.MD5))
 
 isValidPass :: Text -- ^ cleartext password
             -> SaltedPass -- ^ salted password

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -74,7 +74,11 @@ import           Control.Monad.IO.Class   (MonadIO)
 import qualified Crypto.Nonce             as Nonce
 import           Data.Aeson               ((.:?))
 import qualified Data.Aeson               as A
+#if MIN_VERSION_aeson(1,0,0)
+import qualified Data.Aeson.Text          as A
+#else
 import qualified Data.Aeson.Encode        as A
+#endif
 import           Data.Aeson.Parser        (json')
 import           Data.Aeson.Types         (FromJSON (parseJSON), parseEither,
                                            parseMaybe, withObject, withText)

yesod-auth/Yesod/Auth/Message.hs

@@ -19,6 +19,7 @@ module Yesod.Auth.Message
     , russianMessage
     , dutchMessage
     , danishMessage
+    , koreanMessage
     ) where
 
 import           Data.Monoid (mappend, (<>))
@@ -75,9 +76,9 @@ defaultMessage = englishMessage
 
 englishMessage :: AuthMessage -> Text
 englishMessage NoOpenID = "No OpenID identifier found"
-englishMessage LoginOpenID = "Login via OpenID"
+englishMessage LoginOpenID = "Log in via OpenID"
-englishMessage LoginGoogle = "Login via Google"
+englishMessage LoginGoogle = "Log in via Google"
-englishMessage LoginYahoo = "Login via Yahoo"
+englishMessage LoginYahoo = "Log in via Yahoo"
 englishMessage Email = "Email"
 englishMessage UserName = "User name"
 englishMessage Password = "Password"
@@ -101,8 +102,8 @@ englishMessage NewPass = "New password"
 englishMessage ConfirmPass = "Confirm"
 englishMessage PassMismatch = "Passwords did not match, please try again"
 englishMessage PassUpdated = "Password updated"
-englishMessage Facebook = "Login with Facebook"
+englishMessage Facebook = "Log in with Facebook"
-englishMessage LoginViaEmail = "Login via email"
+englishMessage LoginViaEmail = "Log in via email"
 englishMessage InvalidLogin = "Invalid login"
 englishMessage NowLoggedIn = "You are now logged in"
 englishMessage LoginTitle = "Log In"
@@ -174,7 +175,7 @@ spanishMessage LoginOpenID = "Entrar utilizando OpenID"
 spanishMessage LoginGoogle = "Entrar utilizando Google"
 spanishMessage LoginYahoo = "Entrar utilizando Yahoo"
 spanishMessage Email = "Correo electrónico"
-spanishMessage UserName = "Nombre de Usuario" -- FIXME by Google Translate "user name"
+spanishMessage UserName = "Nombre de Usuario"
 spanishMessage Password = "Contraseña"
 spanishMessage CurrentPassword = "Contraseña actual"
 spanishMessage Register = "Registrarse"
@@ -205,9 +206,9 @@ spanishMessage PleaseProvideUsername = "Por favor escriba su nombre de usuario"
 spanishMessage PleaseProvidePassword = "Por favor escriba su contraseña"
 spanishMessage NoIdentifierProvided = "No ha indicado una cuenta de correo/nombre de usuario"
 spanishMessage InvalidEmailAddress = "La cuenta de correo es inválida"
-spanishMessage PasswordResetTitle = "Contraseña actualizada"
+spanishMessage PasswordResetTitle = "Actualización de contraseña"
 spanishMessage ProvideIdentifier = "Cuenta de correo o nombre de usuario"
-spanishMessage SendPasswordResetEmail = "Correo de actualización de contraseña enviado"
+spanishMessage SendPasswordResetEmail = "Enviar correo de actualización de contraseña"
 spanishMessage PasswordResetPrompt = "Escriba su cuenta de correo o nombre de usuario, y una confirmación de actualización de contraseña será enviada a su cuenta de correo."
 spanishMessage InvalidUsernamePass = "Combinación de nombre de usuario/contraseña invalida"
 -- TODO
@@ -416,7 +417,7 @@ japaneseMessage LoginYahoo = "Yahooでログイン"
 japaneseMessage Email = "Eメール"
 japaneseMessage UserName = "ユーザー名" -- FIXME by Google Translate "user name"
 japaneseMessage Password = "パスワード"
-japaneseMessage CurrentPassword = "Current password"
+japaneseMessage CurrentPassword = "現在のパスワード"
 japaneseMessage Register = "登録"
 japaneseMessage RegisterLong = "新規アカウント登録"
 japaneseMessage EnterEmail = "メールアドレスを入力してください。確認メールが送られます"
@@ -511,9 +512,9 @@ chineseMessage LoginOpenID = "用OpenID登录"
 chineseMessage LoginGoogle = "用Google帐户登录"
 chineseMessage LoginYahoo = "用Yahoo帐户登录"
 chineseMessage Email = "邮箱"
-chineseMessage UserName = "用户名" -- FIXME by Google Translate "user name"
+chineseMessage UserName = "用户名"
 chineseMessage Password = "密码"
-chineseMessage CurrentPassword = "Current password"
+chineseMessage CurrentPassword = "当前密码"
 chineseMessage Register = "注册"
 chineseMessage RegisterLong = "注册新帐户"
 chineseMessage EnterEmail = "输入你的邮箱地址，你将收到一封确认邮件。"
@@ -547,11 +548,10 @@ chineseMessage ProvideIdentifier = "邮箱或用户名"
 chineseMessage SendPasswordResetEmail = "发送密码重置邮件"
 chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。"
 chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"
--- TODO
+chineseMessage (IdentifierNotFound ident) = "邮箱/用户名不存在: " `mappend` ident
-chineseMessage i@(IdentifierNotFound _) = englishMessage i
+chineseMessage Logout = "注销"
-chineseMessage Logout = "註銷" -- FIXME by Google Translate
+chineseMessage LogoutTitle = "注销"
-chineseMessage LogoutTitle = "註銷" -- FIXME by Google Translate
+chineseMessage AuthError = "验证错误"
-chineseMessage AuthError = "验证错误" -- FIXME by Google Translate
 
 czechMessage :: AuthMessage -> Text
 czechMessage NoOpenID = "Nebyl nalezen identifikátor OpenID"
@@ -785,3 +785,50 @@ danishMessage (IdentifierNotFound ident) = "Brugernavn findes ikke: " `mappend`
 danishMessage Logout = "Log ud"
 danishMessage LogoutTitle = "Log ud"
 danishMessage AuthError = "Fejl ved bekræftelse af identitet"
+
+koreanMessage :: AuthMessage -> Text
+koreanMessage NoOpenID = "OpenID ID가 없습니다"
+koreanMessage LoginOpenID = "OpenID로 로그인"
+koreanMessage LoginGoogle = "Google로 로그인"
+koreanMessage LoginYahoo = "Yahoo로 로그인"
+koreanMessage Email = "이메일"
+koreanMessage UserName = "사용자 이름"
+koreanMessage Password = "비밀번호"
+koreanMessage CurrentPassword = "현재 비밀번호"
+koreanMessage Register = "등록"
+koreanMessage RegisterLong = "새 계정 등록"
+koreanMessage EnterEmail = "이메일 주소를 아래에 입력하시면 확인 이메일이 발송됩니다."
+koreanMessage ConfirmationEmailSentTitle = "확인 이메일을 보냈습니다"
+koreanMessage (ConfirmationEmailSent email) =
+    "확인 이메일을 " `mappend`
+    email `mappend`
+    "에 보냈습니다."
+koreanMessage AddressVerified = "주소가 인증되었습니다. 새 비밀번호를 설정하세요."
+koreanMessage InvalidKeyTitle = "인증키가 잘못되었습니다"
+koreanMessage InvalidKey = "죄송합니다. 잘못된 인증키입니다."
+koreanMessage InvalidEmailPass = "이메일 주소나 비밀번호가 잘못되었습니다"
+koreanMessage BadSetPass = "비밀번호를 설정하기 위해서는 로그인해야 합니다"
+koreanMessage SetPassTitle = "비밀번호 설정"
+koreanMessage SetPass = "새 비밀번호 설정"
+koreanMessage NewPass = "새 비밀번호"
+koreanMessage ConfirmPass = "확인"
+koreanMessage PassMismatch = "비밀번호가 맞지 않습니다. 다시 시도해주세요."
+koreanMessage PassUpdated = "비밀번호가 업데이트 되었습니다"
+koreanMessage Facebook = "Facebook으로 로그인"
+koreanMessage LoginViaEmail = "이메일로"
+koreanMessage InvalidLogin = "잘못된 로그인입니다"
+koreanMessage NowLoggedIn = "로그인했습니다"
+koreanMessage LoginTitle = "로그인"
+koreanMessage PleaseProvideUsername = "사용자 이름을 입력하세요"
+koreanMessage PleaseProvidePassword = "비밀번호를 입력하세요"
+koreanMessage NoIdentifierProvided = "이메일 주소나 사용자 이름이 입력되어 있지 않습니다"
+koreanMessage InvalidEmailAddress = "이메일 주소가 잘못되었습니다"
+koreanMessage PasswordResetTitle = "비밀번호 변경"
+koreanMessage ProvideIdentifier = "이메일 주소나 사용자 이름"
+koreanMessage SendPasswordResetEmail = "비밀번호 재설정 이메일 보내기"
+koreanMessage PasswordResetPrompt = "이메일 주소나 사용자 이름을 아래에 입력하시면 비밀번호 재설정 이메일이 발송됩니다."
+koreanMessage InvalidUsernamePass = "사용자 이름이나 비밀번호가 잘못되었습니다"
+koreanMessage (IdentifierNotFound ident) = ident `mappend` "는 등록되어 있지 않습니다"
+koreanMessage Logout = "로그아웃"
+koreanMessage LogoutTitle = "로그아웃"
+koreanMessage AuthError = "인증오류"

yesod-auth/Yesod/Auth/Util/PasswordStore.hs

@@ -1,13 +1,8 @@
 {-# LANGUAGE OverloadedStrings, BangPatterns #-}
 {-# LANGUAGE CPP #-}
 -- |
--- Module      : Crypto.PasswordStore
+-- This is a fork of pwstore-fast, originally copyright (c) Peter Scott, 2011,
--- Copyright   : (c) Peter Scott, 2011
+-- and released under a BSD-style licence.
--- License     : BSD-style
---
--- Maintainer  : pjscott@iastate.edu
--- Stability   : experimental
--- Portability : portable
 --
 -- Securely store hashed, salted passwords. If you need to store and verify
 -- passwords, there are many wrong ways to do it, most of them all too
@@ -70,8 +65,10 @@
 -- Note that, as of version 2.4, you can also use PBKDF2, and specify the exact
 -- iteration count. This does not have a significant effect on security, but can
 -- be handy for compatibility with other code.
+--
+-- @since 1.4.18
 
-module Yesod.PasswordStore (
+module Yesod.Auth.Util.PasswordStore (
 
         -- * Algorithms
         pbkdf1,                 -- :: ByteString -> Salt -> Int -> ByteString
@@ -102,16 +99,14 @@ module Yesod.PasswordStore (
         importSalt              -- :: ByteString -> Salt
   ) where
 
-
+import qualified Crypto.MAC.HMAC as CH
 import qualified Crypto.Hash as CH
-import qualified Crypto.Hash.SHA256 as H
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.Binary as Binary
 import Control.Monad
 import Control.Monad.ST
-import Data.Byteable (toBytes)
 import Data.STRef
 import Data.Bits
 import Data.ByteString.Char8 (ByteString)
@@ -120,6 +115,7 @@ import System.IO
 import System.Random
 import Data.Maybe
 import qualified Control.Exception
+import Data.ByteArray (convert)
 
 ---------------------
 -- Cryptographic base
@@ -132,16 +128,23 @@ import qualified Control.Exception
 -- key should be stored in the password file. When a user wishes to authenticate
 -- a password, just pass it and the salt to this function, and see if the output
 -- matches.
+--
+-- @since 1.4.18
+--
 pbkdf1 :: ByteString -> Salt -> Int -> ByteString
 pbkdf1 password (SaltBS salt) iter = hashRounds first_hash (iter + 1)
-    where first_hash = H.finalize $ H.init `H.update` password `H.update` salt
+  where
+    first_hash =
+      convert $
+      ((CH.hashFinalize $ CH.hashInit `CH.hashUpdate` password `CH.hashUpdate` salt) :: CH.Digest CH.SHA256)
+
 
 -- | Hash a 'ByteString' for a given number of rounds. The number of rounds is 0
 -- or more. If the number of rounds specified is 0, the ByteString will be
 -- returned unmodified.
 hashRounds :: ByteString -> Int -> ByteString
 hashRounds (!bs) 0 = bs
-hashRounds bs rounds = hashRounds (H.hash bs) (rounds - 1)
+hashRounds bs rounds = hashRounds (convert (CH.hash bs :: CH.Digest CH.SHA256)) (rounds - 1)
 
 -- | Computes the hmacSHA256 of the given message, with the given 'Salt'.
 hmacSHA256 :: ByteString
@@ -151,13 +154,16 @@ hmacSHA256 :: ByteString
            -> ByteString
            -- ^ The encoded message
 hmacSHA256 secret msg =
-    toBytes (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)
+    convert (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)
 
 -- | PBKDF2 key-derivation function.
 -- For details see @http://tools.ietf.org/html/rfc2898@.
 -- @32@ is the most common digest size for @SHA256@, and is
 -- what the algorithm internally uses.
 -- @HMAC+SHA256@ is used as @PRF@, because @HMAC+SHA1@ is considered too weak.
+--
+-- @since 1.4.18
+--
 pbkdf2 :: ByteString -> Salt -> Int -> ByteString
 pbkdf2 password (SaltBS salt) c =
     let hLen = 32
@@ -196,6 +202,9 @@ pbkdf2 password (SaltBS salt) c =
 -- | Generate a 'Salt' from 128 bits of data from @\/dev\/urandom@, with the
 -- system RNG as a fallback. This is the function used to generate salts by
 -- 'makePassword'.
+--
+-- @since 1.4.18
+--
 genSaltIO :: IO Salt
 genSaltIO =
     Control.Exception.catch genSaltDevURandom def
@@ -249,6 +258,9 @@ writePwHash (strength, SaltBS salt, hash) =
 -- database. Generates a salt using high-quality randomness from
 -- @\/dev\/urandom@ or (if that is not available, for example on Windows)
 -- 'System.Random', which is included in the hashed output.
+--
+-- @since 1.4.18
+--
 makePassword :: ByteString -> Int -> IO ByteString
 makePassword = makePasswordWith pbkdf1
 
@@ -257,6 +269,8 @@ makePassword = makePasswordWith pbkdf1
 --
 -- >>> makePasswordWith pbkdf1 "password" 14
 --
+-- @since 1.4.18
+--
 makePasswordWith :: (ByteString -> Salt -> Int -> ByteString)
                  -- ^ The algorithm to use (e.g. pbkdf1)
                  -> ByteString
@@ -273,6 +287,9 @@ makePasswordWith algorithm password strength = do
 -- Note that, unlike 'makePasswordWith', this function takes the @raw@
 -- number of iterations. This means the user will need to specify a
 -- sensible value, typically @10000@ or @20000@.
+--
+-- @since 1.4.18
+--
 makePasswordSaltWith :: (ByteString -> Salt -> Int -> ByteString)
                      -- ^ A function modeling an algorithm (e.g. 'pbkdf1')
                      -> (Int -> Int)
@@ -293,6 +310,9 @@ makePasswordSaltWith algorithm strengthModifier pwd salt strength = writePwHash
 --
 -- > >>> makePasswordSalt "hunter2" (makeSalt "72cd18b5ebfe6e96") 14
 -- > "sha256|14|NzJjZDE4YjVlYmZlNmU5Ng==|yuiNrZW3KHX+pd0sWy9NTTsy5Yopmtx4UYscItSsoxc="
+--
+-- @since 1.4.18
+--
 makePasswordSalt :: ByteString -> Salt -> Int -> ByteString
 makePasswordSalt = makePasswordSaltWith pbkdf1 (2^)
 
@@ -309,6 +329,8 @@ makePasswordSalt = makePasswordSaltWith pbkdf1 (2^)
 -- > >>> verifyPasswordWith pbkdf2 id "hunter2" "sha256..."
 -- > True
 --
+-- @since 1.4.18
+--
 verifyPasswordWith :: (ByteString -> Salt -> Int -> ByteString)
                    -- ^ A function modeling an algorithm (e.g. pbkdf1)
                    -> (Int -> Int)
@@ -325,6 +347,9 @@ verifyPasswordWith algorithm strengthModifier userInput pwHash =
           encode (algorithm userInput salt (strengthModifier strength)) == goodHash
 
 -- | Like 'verifyPasswordWith', but uses 'pbkdf1' as algorithm.
+--
+-- @since 1.4.18
+--
 verifyPassword :: ByteString -> ByteString -> Bool
 verifyPassword = verifyPasswordWith pbkdf1 (2^)
 
@@ -338,6 +363,9 @@ verifyPassword = verifyPasswordWith pbkdf1 (2^)
 -- This function can be used to periodically update your password database when
 -- computers get faster, in order to keep up with Moore's law. This isn't hugely
 -- important, but it's a good idea.
+--
+-- @since 1.4.18
+--
 strengthenPassword :: ByteString -> Int -> ByteString
 strengthenPassword pwHash newstr =
     case readPwHash pwHash of
@@ -352,6 +380,9 @@ strengthenPassword pwHash newstr =
                 hash = decodeLenient hashB64
 
 -- | Return the strength of a password hash.
+--
+-- @since 1.4.18
+--
 passwordStrength :: ByteString -> Int
 passwordStrength pwHash = case readPwHash pwHash of
                             Nothing               -> 0
@@ -365,12 +396,18 @@ passwordStrength pwHash = case readPwHash pwHash of
 -- hash. You can generate a salt with 'genSaltIO' or 'genSaltRandom', or if you
 -- really know what you're doing, you can create them from your own ByteString
 -- values with 'makeSalt'.
+--
+-- @since 1.4.18
+--
 newtype Salt = SaltBS ByteString
     deriving (Show, Eq, Ord)
 
 -- | Create a 'Salt' from a 'ByteString'. The input must be at least 8
 -- characters, and can contain arbitrary bytes. Most users will not need to use
 -- this function.
+--
+-- @since 1.4.18
+--
 makeSalt :: ByteString -> Salt
 makeSalt = SaltBS . encode . check_length
     where check_length salt | B.length salt < 8 =
@@ -379,17 +416,26 @@ makeSalt = SaltBS . encode . check_length
 
 -- | Convert a 'Salt' into a 'ByteString'. The resulting 'ByteString' will be
 -- base64-encoded. Most users will not need to use this function.
+--
+-- @since 1.4.18
+--
 exportSalt :: Salt -> ByteString
 exportSalt (SaltBS bs) = bs
 
 -- | Convert a raw 'ByteString' into a 'Salt'.
 -- Use this function with caution, since using a weak salt will result in a
 -- weak password.
+--
+-- @since 1.4.18
+--
 importSalt :: ByteString -> Salt
 importSalt = SaltBS
 
 -- | Is the format of a password hash valid? Attempts to parse a given password
 -- hash. Returns 'True' if it parses correctly, and 'False' otherwise.
+--
+-- @since 1.4.18
+--
 isPasswordFormatValid :: ByteString -> Bool
 isPasswordFormatValid = isJust . readPwHash
 
@@ -397,6 +443,9 @@ isPasswordFormatValid = isJust . readPwHash
 -- generator. Returns the salt and the updated random number generator. This is
 -- meant to be used with 'makePasswordSalt' by people who would prefer to either
 -- use their own random number generator or avoid the 'IO' monad.
+--
+-- @since 1.4.18
+--
 genSaltRandom :: (RandomGen b) => b -> (Salt, b)
 genSaltRandom gen = (salt, newgen)
     where rands _ 0 = []

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.4.18
+version:         1.4.21
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -27,7 +27,8 @@ library
                    , wai                     >= 1.4
                    , template-haskell
                    , base16-bytestring
-                   , cryptohash
+                   , cryptonite
+                   , memory
                    , random                  >= 1.0.0.2
                    , text                    >= 0.7
                    , mime-mail               >= 0.3
@@ -37,8 +38,8 @@ library
                    , unordered-containers
                    , yesod-form              >= 1.4       && < 1.5
                    , transformers            >= 0.2.2
-                   , persistent              >= 2.1       && < 2.7
+                   , persistent              >= 2.1       && < 2.8
-                   , persistent-template     >= 2.1       && < 2.7
+                   , persistent-template     >= 2.1       && < 2.8
                    , http-client
                    , http-conduit            >= 2.1
                    , aeson                   >= 0.7
@@ -76,8 +77,8 @@ library
                      Yesod.Auth.GoogleEmail
                      Yesod.Auth.GoogleEmail2
                      Yesod.Auth.Hardcoded
+                     Yesod.Auth.Util.PasswordStore
     other-modules:   Yesod.Auth.Routes
-                     Yesod.PasswordStore
     ghc-options:     -Wall
 
 source-repository head

yesod-bin/AddHandler.hs

@@ -5,9 +5,13 @@ import Prelude hiding (readFile)
 import System.IO  (hFlush, stdout)
 import Data.Char  (isLower, toLower, isSpace)
 import Data.List  (isPrefixOf, isSuffixOf, stripPrefix)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, listToMaybe)
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
+import Distribution.PackageDescription.Parse (readPackageDescription)
+import Distribution.PackageDescription.Configuration (flattenPackageDescription)
+import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)
+import Distribution.Verbosity (normal)
 import System.Directory (getDirectoryContents, doesFileExist)
 import Control.Monad (unless)
 
@@ -31,7 +35,7 @@ cmdLineArgsError = "You have to specify a route name if you want to add handler
 addHandler :: Maybe String -> Maybe String -> [String] -> IO ()
 addHandler (Just route) pat met = do
     cabal <- getCabal
-    checked <- checkRoute route
+    checked <- checkRoute route cabal
     let routePair = case checked of
           Left err@EmptyRoute -> (error . show) err
           Left err@RouteCaseError -> (error . show) err
@@ -54,7 +58,7 @@ addHandlerInteractive = do
         putStr "Name of route (without trailing R): "
         hFlush stdout
         name <- getLine
-        checked <- checkRoute name
+        checked <- checkRoute name cabal
         case checked of
             Left err@EmptyRoute -> (error . show) err
             Left err@RouteCaseError -> print err >> routeInput
@@ -75,7 +79,9 @@ addHandlerInteractive = do
 
 addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO ()
 addHandlerFiles cabal (name, handlerFile) pattern methods = do
-    modify "Application.hs" $ fixApp name
+    src <- getSrcDir cabal
+    let applicationFile = concat [src, "/Application.hs"]
+    modify applicationFile $ fixApp name
     modify cabal $ fixCabal name
     modify "config/routes" $ fixRoutes name pattern methods
     writeFile handlerFile $ mkHandler name pattern methods
@@ -94,15 +100,16 @@ getCabal = do
         [] -> error "No cabal file found"
         _ -> error "Too many cabal files found"
 
-checkRoute :: String -> IO (Either RouteError (String, FilePath))
+checkRoute :: String -> FilePath -> IO (Either RouteError (String, FilePath))
-checkRoute name =
+checkRoute name cabal =
     case name of
         [] -> return $ Left EmptyRoute
         c:_
             | isLower c -> return $ Left RouteCaseError
             | otherwise -> do
                 -- Check that the handler file doesn't already exist
-                let handlerFile = concat ["Handler/", name, ".hs"]
+                src <- getSrcDir cabal
+                let handlerFile = concat [src, "/Handler/", name, ".hs"]
                 exists <- doesFileExist handlerFile
                 if exists
                     then (return . Left . RouteExists) handlerFile
@@ -214,3 +221,10 @@ mkHandler name pattern methods = unlines
 uncapitalize :: String -> String
 uncapitalize (x:xs) = toLower x : xs
 uncapitalize "" = ""
+
+getSrcDir :: FilePath -> IO FilePath
+getSrcDir cabal = do
+    pd <- flattenPackageDescription <$> readPackageDescription normal cabal
+    let buildInfo = allBuildInfo pd
+        srcDirs = concatMap hsSourceDirs buildInfo
+    return $ fromMaybe "." $ listToMaybe srcDirs

yesod-bin/ChangeLog.md

@@ -1,3 +1,31 @@
+## 1.5.2.6
+
+* Drop an upper bound
+
+## 1.5.2.5
+
+* Support for `add-handler` when modules are in `src/` directory [#1413](https://github.com/yesodweb/yesod/issues/1413)
+
+## 1.5.2.4
+
+* Cabal 2.0 support
+
+## 1.5.2.3
+
+* Fix race condition which leads dev server to stay in compilation mode. [#1380](https://github.com/yesodweb/yesod/issues/1380)
+
+## 1.5.2.2
+
+* I guess `--no-nix-pure` implies Nix... sigh [#1359](https://github.com/yesodweb/yesod/issues/1359)
+
+## 1.5.2.1
+
+* Use `--no-nix-pure` [#1357](https://github.com/yesodweb/yesod/issues/1357)
+
+## 1.5.2
+
+* Fix warnings
+
 ## 1.5.1
 
 * Add `--host` option to `yesod devel`

yesod-bin/Devel.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE TemplateHaskell     #-}
@@ -14,6 +15,7 @@ import           Control.Concurrent.STM
 import qualified Control.Exception.Safe                as Ex
 import           Control.Monad                         (forever, unless, void,
                                                         when)
+import Data.ByteString (ByteString, isInfixOf)
 import qualified Data.ByteString.Lazy                  as LB
 import           Data.Conduit                          (($$), (=$))
 import qualified Data.Conduit.Binary                   as CB
@@ -21,6 +23,7 @@ import qualified Data.Conduit.List                     as CL
 import           Data.Default.Class                    (def)
 import           Data.FileEmbed                        (embedFile)
 import qualified Data.Map                              as Map
+import           Data.Maybe                            (isJust)
 import qualified Data.Set                              as Set
 import           Data.Streaming.Network                (bindPortTCP,
                                                         bindRandomPortTCP)
@@ -125,6 +128,7 @@ reverseProxy :: DevelOpts -> TVar Int -> IO ()
 reverseProxy opts appPortVar = do
     manager <- newManager $ managerSetProxy noProxy tlsManagerSettings
     let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")]
+        sayV = when (verbose opts) . sayString    
     let onExc _ req
             | maybe False (("application/json" `elem`) . parseHttpAccept)
                 (lookup "accept" $ requestHeaders req) =
@@ -141,6 +145,7 @@ reverseProxy opts appPortVar = do
     let proxyApp = waiProxyToSettings
                 (const $ do
                     appPort <- atomically $ readTVar appPortVar
+                    sayV $ "revProxy: appPort " ++ (show appPort)
                     return $
                         ReverseProxy.WPRProxyDest
                         $ ProxyDest "127.0.0.1" appPort)
@@ -221,12 +226,40 @@ checkDevelFile =
             then return x
             else loop xs
 
+stackSuccessString :: ByteString
+stackSuccessString = "ExitSuccess"
+
+stackFailureString :: ByteString
+stackFailureString = "ExitFailure"
+
+-- We need updateAppPort logic to prevent a race condition.
+-- See https://github.com/yesodweb/yesod/issues/1380
+updateAppPort :: ByteString -> TVar Bool -- ^ Bool to indicate if the
+                                         -- output from stack has
+                                         -- started. False indicate
+                                         -- that it hasn't started
+                                         -- yet.
+              -> TVar Int -> STM ()
+updateAppPort bs buildStarted appPortVar = do
+  hasStarted <- readTVar buildStarted
+  let buildEnd = isInfixOf stackFailureString bs || isInfixOf stackSuccessString bs
+  case (hasStarted, buildEnd) of
+    (False, False) -> do
+      writeTVar appPortVar (-1 :: Int)
+      writeTVar buildStarted True
+    (True, False) -> return ()
+    (_, True) -> writeTVar buildStarted False
+
 -- | Get the set of all flags available in the given cabal file
 getAvailableFlags :: D.GenericPackageDescription -> Set.Set String
 getAvailableFlags =
     Set.fromList . map (unFlagName . D.flagName) . D.genPackageFlags
   where
+#if MIN_VERSION_Cabal(2, 0, 0)
+    unFlagName = D.unFlagName
+#else
     unFlagName (D.FlagName fn) = fn
+#endif
 
 -- | This is the main entry point. Run the devel server.
 devel :: DevelOpts -- ^ command line options
@@ -247,9 +280,20 @@ devel opts passThroughArgs = do
 #else
     cabal  <- D.findPackageDesc "."
 #endif
+
+#if MIN_VERSION_Cabal(2, 0, 0)
+    gpd    <- D.readGenericPackageDescription D.normal cabal
+#else
     gpd    <- D.readPackageDescription D.normal cabal
+#endif
+
     let pd = D.packageDescription gpd
-        D.PackageIdentifier (D.PackageName packageName) _version = D.package pd
+        D.PackageIdentifier packageNameWrapped _version = D.package pd
+#if MIN_VERSION_Cabal(2, 0, 0)
+        packageName = D.unPackageName packageNameWrapped
+#else
+        D.PackageName packageName = packageNameWrapped
+#endif
 
     -- Which file contains the code to run
     develHsPath <- checkDevelFile
@@ -282,6 +326,7 @@ devel opts passThroughArgs = do
     sayV = when (verbose opts) . sayString
 
     -- Leverage "stack build --file-watch" to do the build
+    runStackBuild :: TVar Int -> [Char] -> Set.Set [Char] -> IO ()
     runStackBuild appPortVar packageName availableFlags = do
         -- We call into this app for the devel-signal command
         myPath <- getExecutablePath
@@ -315,7 +360,7 @@ devel opts passThroughArgs = do
                 passThroughArgs
 
         sayV $ show procConfig
-
+        buildStarted <- newTVarIO False
         -- Monitor the stdout and stderr content from the build process. Any
         -- time some output comes, we invalidate the currently running app by
         -- changing the destination port for reverse proxying to -1. We also
@@ -324,12 +369,13 @@ devel opts passThroughArgs = do
         withProcess_ procConfig $ \p -> do
             let helper getter h =
                       getter p
-                   $$ CL.iterM (\_ -> atomically $ writeTVar appPortVar (-1))
+                   $$ CL.iterM (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
                    =$ CB.sinkHandle h
             race_ (helper getStdout stdout) (helper getStderr stderr)
 
     -- Run the inner action with a TVar which will be set to True
     -- whenever the signal file is modified.
+    withChangedVar :: (TVar Bool -> IO a) -> IO a
     withChangedVar inner = withManager $ \manager -> do
         -- Variable indicating that the signal file has been changed. We
         -- reset it each time we handle the signal.
@@ -352,6 +398,7 @@ devel opts passThroughArgs = do
         inner changedVar
 
     -- Each time the library builds successfully, run the application
+    runApp :: TVar Int -> TVar Bool -> String -> IO b
     runApp appPortVar changedVar develHsPath = do
         -- Wait for the first change, indicating that the library
         -- has been built
@@ -362,9 +409,11 @@ devel opts passThroughArgs = do
 
         sayV "First successful build complete, running app"
 
-        -- We're going to set the PORT and DISPLAY_PORT variables
+        -- We're going to set the PORT and DISPLAY_PORT variables for
-        -- for the child below
+        -- the child below. Also need to know if the env program
+        -- exists.
         env <- fmap Map.fromList getEnvironment
+        hasEnv <- fmap isJust $ findExecutable "env"
 
         -- Keep looping forever, print any synchronous exceptions,
         -- and eventually die from an async exception from one of
@@ -405,7 +454,26 @@ devel opts passThroughArgs = do
                     , "Main.main"
                     ]
             -}
-            let procDef = setStdin closed $ setEnv env' $ proc "stack"
+
+            -- Nix support in Stack doesn't pass along env vars by
+            -- default, so we use the env command. But if the command
+            -- isn't available, just set the env var. I'm sure this
+            -- will break _some_ combination of systems, but we'll
+            -- deal with that later. Previous issues:
+            --
+            -- https://github.com/yesodweb/yesod/issues/1357
+            -- https://github.com/yesodweb/yesod/issues/1359
+            let procDef
+                  | hasEnv = setStdin closed $ proc "stack"
+                    [ "exec"
+                    , "--"
+                    , "env"
+                    , "PORT=" ++ show newPort
+                    , "DISPLAY_PORT=" ++ show (develPort opts)
+                    , "runghc"
+                    , develHsPath
+                    ]
+                  | otherwise = setStdin closed $ setEnv env' $ proc "stack"
                     [ "runghc"
                     , "--"
                     , develHsPath

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.5.1
+version:         1.5.2.6
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -33,7 +33,7 @@ executable             yesod
                      , template-haskell
                      , directory          >= 1.2.1
                      , Cabal              >= 1.18
-                     , unix-compat        >= 0.2          && < 0.5
+                     , unix-compat        >= 0.2
                      , containers         >= 0.2
                      , attoparsec         >= 0.10
                      , http-types         >= 0.7

yesod-core/ChangeLog.md

@@ -1,3 +1,43 @@
+## 1.4.37.2
+
+* Improve error messages for the CSRF checking functions [#1455](https://github.com/yesodweb/yesod/issues/1455)
+
+## 1.4.37.1
+
+* Fix documentation on `languages` function, update `getMessageRender` to use said function. [#1457](https://github.com/yesodweb/yesod/pull/1457)
+
+## 1.4.37
+
+* Add `setWeakEtag` function in Yesod.Core.Handler module.
+
+## 1.4.36
+
+* Add `replaceOrAddHeader` function in Yesod.Core.Handler module. [1416](https://github.com/yesodweb/yesod/issues/1416)
+
+## 1.4.35.1
+
+* TH fix for GHC 8.2
+
+## 1.4.35
+
+* Contexts can be included in generated TH instances. [1365](https://github.com/yesodweb/yesod/issues/1365)
+* Type variables can be included in routes.
+
+## 1.4.34
+
+* Add `WaiSubsiteWithAuth`. [#1394](https://github.com/yesodweb/yesod/pull/1394)
+
+## 1.4.33
+
+* Adds curly brackets to route parser. [#1363](https://github.com/yesodweb/yesod/pull/1363)
+
+## 1.4.32
+
+* Fix warnings
+* Route parsing handles CRLF line endings
+* Add 'getPostParams' in Yesod.Core.Handler
+* Haddock rendering improved.
+
 ## 1.4.31
 
 * Add `parseCheckJsonBody` and `requireCheckJsonBody`

yesod-core/Yesod/Core/Class/Dispatch.hs

@@ -10,7 +10,7 @@ import Yesod.Routes.Class
 import qualified Network.Wai as W
 import Yesod.Core.Types
 import Yesod.Core.Content
-import Yesod.Core.Handler (stripHandlerT)
+import Yesod.Core.Handler (sendWaiApplication, stripHandlerT)
 import Yesod.Core.Class.Yesod
 import Yesod.Core.Class.Handler
 
@@ -28,6 +28,15 @@ instance YesodSubDispatch WaiSubsite master where
       where
         WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
 
+instance YesodSubDispatch WaiSubsiteWithAuth (HandlerT master IO) where
+  yesodSubDispatch YesodSubRunnerEnv {..} req =
+      ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req
+    where
+      base  = stripHandlerT handlert ysreGetSub ysreToParentRoute route
+      route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []
+      WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
+      handlert = sendWaiApplication $ set
+
 -- | A helper function for creating YesodSubDispatch instances, used by the
 -- internal generated code. This function has been exported since 1.4.11.
 -- It promotes a subsite handler to a wai application.

yesod-core/Yesod/Core/Content.hs

@@ -66,7 +66,8 @@ import Data.Conduit.Internal (ResumableSource (ResumableSource))
 import qualified Data.Conduit.Internal as CI
 
 import qualified Data.Aeson as J
-#if MIN_VERSION_aeson(0, 7, 0)
+#if MIN_VERSION_aeson(1, 0, 0)
+#elif MIN_VERSION_aeson(0, 7, 0)
 import Data.Aeson.Encode (encodeToTextBuilder)
 #else
 import Data.Aeson.Encode (fromValue)
@@ -242,6 +243,11 @@ instance ToContent a => ToContent (DontFullyEvaluate a) where
     toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a
 
 instance ToContent J.Value where
+#if MIN_VERSION_aeson(1, 0, 0)
+    toContent = flip ContentBuilder Nothing
+              . J.fromEncoding
+              . J.toEncoding
+#else
     toContent = flip ContentBuilder Nothing
               . Blaze.fromLazyText
               . toLazyText
@@ -251,6 +257,8 @@ instance ToContent J.Value where
               . fromValue
 #endif
 
+#endif
+
 #if MIN_VERSION_aeson(0, 11, 0)
 instance ToContent J.Encoding where
     toContent = flip ContentBuilder Nothing . J.fromEncoding

yesod-core/Yesod/Core/Dispatch.hs

@@ -34,6 +34,7 @@ module Yesod.Core.Dispatch
     , defaultMiddlewaresNoLogging
       -- * WAI subsites
     , WaiSubsite (..)
+    , WaiSubsiteWithAuth (..)
     , subHelper
     ) where
 

yesod-core/Yesod/Core/Handler.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -31,6 +32,7 @@ module Yesod.Core.Handler
     , getsYesod
     , getUrlRender
     , getUrlRenderParams
+    , getPostParams
     , getCurrentRoute
     , getRequest
     , waiRequest
@@ -113,6 +115,7 @@ module Yesod.Core.Handler
     , deleteCookie
     , addHeader
     , setHeader
+    , replaceOrAddHeader
     , setLanguage
       -- ** Content caching and expiration
     , cacheSeconds
@@ -120,6 +123,7 @@ module Yesod.Core.Handler
     , alreadyExpired
     , expiresAt
     , setEtag
+    , setWeakEtag
       -- * Session
     , SessionMap
     , lookupSession
@@ -205,7 +209,7 @@ import Control.Monad.Trans.Class (lift)
 
 import           Data.Aeson                    (ToJSON(..))
 import qualified Data.Text                     as T
-import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8)
+import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8, decodeUtf8)
 import           Data.Text.Encoding.Error      (lenientDecode)
 import qualified Data.Text.Lazy                as TL
 import           Text.Blaze.Html.Renderer.Utf8 (renderHtml)
@@ -238,7 +242,7 @@ import           Yesod.Core.Types
 import           Yesod.Routes.Class            (Route)
 import           Blaze.ByteString.Builder (Builder)
 import           Safe (headMay)
-import           Data.CaseInsensitive (CI)
+import           Data.CaseInsensitive (CI, original)
 import qualified Data.Conduit.List as CL
 import           Control.Monad.Trans.Resource  (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)
 import qualified System.PosixCompat.Files as PC
@@ -339,6 +343,18 @@ getUrlRenderParams
     => m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
 getUrlRenderParams = rheRender <$> askHandlerEnv
 
+-- | Get all the post parameters passed to the handler. To also get
+-- the submitted files (if any), you have to use 'runRequestBody'
+-- instead of this function.
+--
+-- @since 1.4.33
+getPostParams
+  :: MonadHandler m
+  => m [(Text, Text)]
+getPostParams = do
+  reqBodyContent <- runRequestBody
+  return $ fst reqBodyContent
+
 -- | Get the route requested by the user. If this is a 404 response- where the
 -- user requested an invalid route- this function will return 'Nothing'.
 getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
@@ -425,7 +441,7 @@ handlerToIO =
 -- Uses 'handlerToIO', liftResourceT, and resourceForkIO
 -- for correctness and efficiency
 --
--- Since 1.2.8
+-- @since 1.2.8
 forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler
               -> HandlerT site IO ()
               -> HandlerT site IO ()
@@ -617,7 +633,7 @@ sendResponseStatus s = handlerError . HCContent s . toTypedContent
 -- | Bypass remaining handler code and output the given JSON with the given
 -- status code.
 --
--- Since 1.4.18
+-- @since 1.4.18
 sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a
 #if MIN_VERSION_aeson(0, 11, 0)
 sendStatusJSON s v = sendResponseStatus s (toEncoding v)
@@ -642,7 +658,7 @@ sendWaiResponse = handlerError . HCWai
 
 -- | Switch over to handling the current request with a WAI @Application@.
 --
--- Since 1.2.17
+-- @since 1.2.17
 sendWaiApplication :: MonadHandler m => W.Application -> m b
 sendWaiApplication = handlerError . HCWaiApp
 
@@ -650,7 +666,7 @@ sendWaiApplication = handlerError . HCWaiApp
 -- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw
 -- responses (e.g., Warp).
 --
--- Since 1.2.16
+-- @since 1.2.16
 sendRawResponseNoConduit
     :: (MonadHandler m, MonadBaseControl IO m)
     => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
@@ -666,7 +682,7 @@ sendRawResponseNoConduit raw = control $ \runInIO ->
 -- WAI 2.1 or later, and a web server which supports raw responses (e.g.,
 -- Warp).
 --
--- Since 1.2.7
+-- @since 1.2.7
 sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
                 => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())
                 -> m a
@@ -685,7 +701,7 @@ sendRawResponse raw = control $ \runInIO ->
 -- | Send a 304 not modified response immediately. This is a short-circuiting
 -- action.
 --
--- Since 1.4.4
+-- @since 1.4.4
 notModified :: MonadHandler m => m a
 notModified = sendWaiResponse $ W.responseBuilder H.status304 [] mempty
 
@@ -765,7 +781,7 @@ setLanguage = setSession langKey
 -- Note that, while the data type used here is 'Text', you must provide only
 -- ASCII value to be HTTP compliant.
 --
--- Since 1.2.0
+-- @since 1.2.0
 addHeader :: MonadHandler m => Text -> Text -> m ()
 addHeader a = addHeaderInternal . Header (encodeUtf8 a) . encodeUtf8
 
@@ -774,6 +790,40 @@ setHeader :: MonadHandler m => Text -> Text -> m ()
 setHeader = addHeader
 {-# DEPRECATED setHeader "Please use addHeader instead" #-}
 
+-- | Replace an existing header with a new value or add a new header
+-- if not present.
+--
+-- Note that, while the data type used here is 'Text', you must provide only
+-- ASCII value to be HTTP compliant.
+--
+-- @since 1.4.36
+replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()
+replaceOrAddHeader a b =
+  modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)}
+  where
+    repHeader = Header (encodeUtf8 a) (encodeUtf8 b)
+
+    sameHeaderName :: Header -> Header -> Bool
+    sameHeaderName (Header n1 _) (Header n2 _) = T.toLower (decodeUtf8 n1) == T.toLower (decodeUtf8 n2)
+    sameHeaderName _ _ = False
+
+    replaceIndividualHeader :: [Header] -> [Header]
+    replaceIndividualHeader [] = [repHeader]
+    replaceIndividualHeader xs = aux xs []
+      where
+        aux [] acc = acc ++ [repHeader]
+        aux (x:xs') acc =
+          if sameHeaderName repHeader x
+            then acc ++
+                 [repHeader] ++
+                 (filter (\header -> not (sameHeaderName header repHeader)) xs')
+            else aux xs' (acc ++ [x])
+
+    replaceHeader :: Endo [Header] -> Endo [Header]
+    replaceHeader endo =
+      let allHeaders :: [Header] = appEndo endo []
+      in Endo (\rest -> replaceIndividualHeader allHeaders ++ rest)
+
 -- | Set the Cache-Control header to indicate this response should be cached
 -- for the given number of seconds.
 cacheSeconds :: MonadHandler m => Int -> m ()
@@ -802,35 +852,78 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
 expiresAt :: MonadHandler m => UTCTime -> m ()
 expiresAt = setHeader "Expires" . formatRFC1123
 
+data Etag
+  = WeakEtag !S.ByteString
+  -- ^ Prefixed by W/ and surrounded in quotes. Signifies that contents are
+  -- semantically identical but make no guarantees about being bytewise identical.
+  | StrongEtag !S.ByteString
+  -- ^ Signifies that contents should be byte-for-byte identical if they match
+  -- the provided ETag
+  | InvalidEtag !S.ByteString
+  -- ^ Anything else that ends up in a header that expects an ETag but doesn't
+  -- properly follow the ETag format specified in RFC 7232, section 2.3
+  deriving (Show, Eq)
+
 -- | Check the if-none-match header and, if it matches the given value, return
 -- a 304 not modified response. Otherwise, set the etag header to the given
 -- value.
 --
 -- Note that it is the responsibility of the caller to ensure that the provided
--- value is a value etag value, no sanity checking is performed by this
+-- value is a valid etag value, no sanity checking is performed by this
 -- function.
 --
--- Since 1.4.4
+-- @since 1.4.4
 setEtag :: MonadHandler m => Text -> m ()
 setEtag etag = do
     mmatch <- lookupHeader "if-none-match"
     let matches = maybe [] parseMatch mmatch
-    if encodeUtf8 etag `elem` matches
+        baseTag = encodeUtf8 etag
+        strongTag = StrongEtag baseTag
+        badTag = InvalidEtag baseTag
+    if any (\tag -> tag == strongTag || tag == badTag) matches
         then notModified
         else addHeader "etag" $ T.concat ["\"", etag, "\""]
 
--- | Parse an if-none-match field according to the spec. Does not parsing on
+
--- weak matches, which are not supported by setEtag.
+-- | Parse an if-none-match field according to the spec.
-parseMatch :: S.ByteString -> [S.ByteString]
+parseMatch :: S.ByteString -> [Etag]
 parseMatch =
     map clean . S.split W8._comma
   where
-    clean = stripQuotes . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace
+    clean = classify . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace
 
-    stripQuotes bs
+    classify bs
         | S.length bs >= 2 && S.head bs == W8._quotedbl && S.last bs == W8._quotedbl
-            = S.init $ S.tail bs
+            = StrongEtag $ S.init $ S.tail bs
-        | otherwise = bs
+        | S.length bs >= 4 &&
+          S.head bs == W8._W &&
+          S.index bs 1 == W8._slash &&
+          S.index bs 2 == W8._quotedbl &&
+          S.last bs == W8._quotedbl
+            = WeakEtag $ S.init $ S.drop 3 bs
+        | otherwise = InvalidEtag bs
+
+-- | Check the if-none-match header and, if it matches the given value, return
+-- a 304 not modified response. Otherwise, set the etag header to the given
+-- value.
+--
+-- A weak etag is only expected to be semantically identical to the prior content,
+-- but doesn't have to be byte-for-byte identical. Therefore it can be useful for
+-- dynamically generated content that may be difficult to perform bytewise hashing
+-- upon.
+--
+-- Note that it is the responsibility of the caller to ensure that the provided
+-- value is a valid etag value, no sanity checking is performed by this
+-- function.
+--
+-- @since 1.4.37
+setWeakEtag :: MonadHandler m => Text -> m ()
+setWeakEtag etag = do
+    mmatch <- lookupHeader "if-none-match"
+    let matches = maybe [] parseMatch mmatch
+    if WeakEtag (encodeUtf8 etag) `elem` matches
+        then notModified
+        else addHeader "etag" $ T.concat ["W/\"", etag, "\""]
 
 -- | Set a variable in the user's session.
 --
@@ -856,7 +949,7 @@ deleteSession = modify . modSession . Map.delete
 
 -- | Clear all session variables.
 --
--- Since: 1.0.1
+-- @since: 1.0.1
 clearSession :: MonadHandler m => m ()
 clearSession = modify $ \x -> x { ghsSession = Map.empty }
 
@@ -896,7 +989,7 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map k
 --
 -- > redirect (NewsfeedR :#: storyId)
 --
--- Since 1.2.9.
+-- @since 1.2.9.
 data Fragment a b = a :#: b deriving (Show, Typeable)
 
 instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where
@@ -960,7 +1053,7 @@ hamletToRepHtml = withUrlRenderer
 
 -- | Deprecated synonym for 'withUrlRenderer'.
 --
--- Since 1.2.0
+-- @since 1.2.0
 giveUrlRenderer :: MonadHandler m
                 => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
                 -> m output
@@ -970,7 +1063,7 @@ giveUrlRenderer = withUrlRenderer
 -- | Provide a URL rendering function to the given function and return the
 -- result. Useful for processing Shakespearean templates.
 --
--- Since 1.2.20
+-- @since 1.2.20
 withUrlRenderer :: MonadHandler m
                 => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
                 -> m output
@@ -986,7 +1079,7 @@ getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)
                  => m (message -> Text)
 getMessageRender = do
     env <- askHandlerEnv
-    l <- reqLangs <$> getRequest
+    l <- languages
     return $ renderMessage (rheSite env) l
 
 -- | Use a per-request cache to avoid performing the same action multiple times.
@@ -998,7 +1091,7 @@ getMessageRender = do
 --
 -- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>
 --
--- Since 1.2.0
+-- @since 1.2.0
 cached :: (MonadHandler m, Typeable a)
        => m a
        -> m a
@@ -1022,7 +1115,7 @@ cached action = do
 -- You can turn those parameters into a ByteString cache key.
 -- For example, caching a lookup of a Link by a token where multiple token lookups might be performed.
 --
--- Since 1.4.0
+-- @since 1.4.0
 cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a
 cachedBy k action = do
     cache <- ghsCacheBy <$> get
@@ -1037,15 +1130,15 @@ cachedBy k action = do
 
 -- | Get the list of supported languages supplied by the user.
 --
--- Languages are determined based on the following three (in descending order
+-- Languages are determined based on the following (in descending order
 -- of preference):
 --
+-- * The _LANG user session variable.
+--
 -- * The _LANG get parameter.
 --
 -- * The _LANG cookie.
 --
--- * The _LANG user session variable.
---
 -- * Accept-Language HTTP header.
 --
 -- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates.
@@ -1063,13 +1156,13 @@ lookup' a = map snd . filter (\x -> a == fst x)
 
 -- | Lookup a request header.
 --
--- Since 1.2.2
+-- @since 1.2.2
 lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString)
 lookupHeader = fmap listToMaybe . lookupHeaders
 
 -- | Lookup a request header.
 --
--- Since 1.2.2
+-- @since 1.2.2
 lookupHeaders :: MonadHandler m => CI S8.ByteString -> m [S8.ByteString]
 lookupHeaders key = do
     req <- waiRequest
@@ -1078,7 +1171,7 @@ lookupHeaders key = do
 -- | Lookup basic authentication data from __Authorization__ header of
 -- request. Returns user name and password
 --
--- Since 1.4.9
+-- @since 1.4.9
 lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text))
 lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization")
   where
@@ -1088,7 +1181,7 @@ lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization")
 -- | Lookup bearer authentication datafrom __Authorization__ header of
 -- request. Returns bearer token value
 --
--- Since 1.4.9
+-- @since 1.4.9
 lookupBearerAuth :: (MonadHandler m) => m (Maybe Text)
 lookupBearerAuth = fmap (>>= getBR)
                    (lookupHeader "Authorization")
@@ -1162,7 +1255,7 @@ lookupCookies pn = do
 -- | Select a representation to send to the client based on the representations
 -- provided inside this do-block. Should be used together with 'provideRep'.
 --
--- Since 1.2.0
+-- @since 1.2.0
 selectRep :: MonadHandler m
           => Writer.Writer (Endo [ProvidedRep m]) ()
           -> m TypedContent
@@ -1218,13 +1311,13 @@ selectRep w = do
 
 -- | Internal representation of a single provided representation.
 --
--- Since 1.2.0
+-- @since 1.2.0
 data ProvidedRep m = ProvidedRep !ContentType !(m Content)
 
 -- | Provide a single representation to be used, based on the request of the
 -- client. Should be used together with 'selectRep'.
 --
--- Since 1.2.0
+-- @since 1.2.0
 provideRep :: (Monad m, HasContentType a)
            => m a
            -> Writer.Writer (Endo [ProvidedRep m]) ()
@@ -1237,7 +1330,7 @@ provideRep handler = provideRepType (getContentType handler) handler
 --
 -- > provideRepType "application/x-special-format" "This is the content"
 --
--- Since 1.2.0
+-- @since 1.2.0
 provideRepType :: (Monad m, ToContent a)
                => ContentType
                -> m a
@@ -1247,7 +1340,7 @@ provideRepType ct handler =
 
 -- | Stream in the raw request body without any parsing.
 --
--- Since 1.2.0
+-- @since 1.2.0
 rawRequestBody :: MonadHandler m => Source m S.ByteString
 rawRequestBody = do
     req <- lift waiRequest
@@ -1267,7 +1360,7 @@ fileSource = transPipe liftResourceT . fileSourceRaw
 --
 -- > respond ct = return . TypedContent ct . toContent
 --
--- Since 1.2.0
+-- @since 1.2.0
 respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent
 respond ct = return . TypedContent ct . toContent
 
@@ -1279,7 +1372,7 @@ respond ct = return . TypedContent ct . toContent
 -- actions make no sense here. For example: short-circuit responses, setting
 -- headers, changing status codes, etc.
 --
--- Since 1.2.0
+-- @since 1.2.0
 respondSource :: ContentType
               -> Source (HandlerT site IO) (Flush Builder)
               -> HandlerT site IO TypedContent
@@ -1293,44 +1386,44 @@ respondSource ctype src = HandlerT $ \hd ->
 -- | In a streaming response, send a single chunk of data. This function works
 -- on most datatypes, such as @ByteString@ and @Html@.
 --
--- Since 1.2.0
+-- @since 1.2.0
 sendChunk :: Monad m => ToFlushBuilder a => a -> Producer m (Flush Builder)
 sendChunk = yield . toFlushBuilder
 
 -- | In a streaming response, send a flush command, causing all buffered data
 -- to be immediately sent to the client.
 --
--- Since 1.2.0
+-- @since 1.2.0
 sendFlush :: Monad m => Producer m (Flush Builder)
 sendFlush = yield Flush
 
 -- | Type-specialized version of 'sendChunk' for strict @ByteString@s.
 --
--- Since 1.2.0
+-- @since 1.2.0
 sendChunkBS :: Monad m => S.ByteString -> Producer m (Flush Builder)
 sendChunkBS = sendChunk
 
 -- | Type-specialized version of 'sendChunk' for lazy @ByteString@s.
 --
--- Since 1.2.0
+-- @since 1.2.0
 sendChunkLBS :: Monad m => L.ByteString -> Producer m (Flush Builder)
 sendChunkLBS = sendChunk
 
 -- | Type-specialized version of 'sendChunk' for strict @Text@s.
 --
--- Since 1.2.0
+-- @since 1.2.0
 sendChunkText :: Monad m => T.Text -> Producer m (Flush Builder)
 sendChunkText = sendChunk
 
 -- | Type-specialized version of 'sendChunk' for lazy @Text@s.
 --
--- Since 1.2.0
+-- @since 1.2.0
 sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder)
 sendChunkLazyText = sendChunk
 
 -- | Type-specialized version of 'sendChunk' for @Html@s.
 --
--- Since 1.2.0
+-- @since 1.2.0
 sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)
 sendChunkHtml = sendChunk
 
@@ -1374,7 +1467,7 @@ stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do
 
 -- | The default cookie name for the CSRF token ("XSRF-TOKEN").
 --
--- Since 1.4.14
+-- @since 1.4.14
 defaultCsrfCookieName :: S8.ByteString
 defaultCsrfCookieName = "XSRF-TOKEN"
 
@@ -1382,7 +1475,7 @@ defaultCsrfCookieName = "XSRF-TOKEN"
 --
 -- The cookie's path is set to @/@, making it valid for your whole website.
 --
--- Since 1.4.14
+-- @since 1.4.14
 setCsrfCookie :: MonadHandler m => m ()
 setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieName, setCookiePath = Just "/" }
 
@@ -1390,7 +1483,7 @@ setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieN
 --
 -- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.
 --
--- Since 1.4.14
+-- @since 1.4.14
 setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m ()
 setCsrfCookieWithCookie cookie  = do
     mCsrfToken <- reqToken <$> getRequest
@@ -1398,70 +1491,79 @@ setCsrfCookieWithCookie cookie  = do
 
 -- | The default header name for the CSRF token ("X-XSRF-TOKEN").
 --
--- Since 1.4.14
+-- @since 1.4.14
 defaultCsrfHeaderName :: CI S8.ByteString
 defaultCsrfHeaderName = "X-XSRF-TOKEN"
 
 -- | Takes a header name to lookup a CSRF token. If the value doesn't match the token stored in the session,
 -- this function throws a 'PermissionDenied' error.
 --
--- Since 1.4.14
+-- @since 1.4.14
 checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m ()
 checkCsrfHeaderNamed headerName = do
-  valid <- hasValidCsrfHeaderNamed headerName
+  (valid, mHeader) <- hasValidCsrfHeaderNamed' headerName
-  unless valid (permissionDenied csrfErrorMessage)
+  unless valid (permissionDenied $ csrfErrorMessage [CSRFHeader (decodeUtf8 $ original headerName) mHeader])
 
 -- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session.
 --
--- Since 1.4.14
+-- @since 1.4.14
 hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool
-hasValidCsrfHeaderNamed headerName = do
+hasValidCsrfHeaderNamed headerName = fst <$> hasValidCsrfHeaderNamed' headerName
+
+-- | Like 'hasValidCsrfHeaderNamed', but also returns the header value to be used in error messages.
+hasValidCsrfHeaderNamed' :: MonadHandler m => CI S8.ByteString -> m (Bool, Maybe Text)
+hasValidCsrfHeaderNamed' headerName = do
   mCsrfToken  <- reqToken <$> getRequest
   mXsrfHeader <- lookupHeader headerName
 
-  return $ validCsrf mCsrfToken mXsrfHeader
+  return $ (validCsrf mCsrfToken mXsrfHeader, decodeUtf8 <$> mXsrfHeader)
 
 -- CSRF Parameter checking
 
 -- | The default parameter name for the CSRF token ("_token")
 --
--- Since 1.4.14
+-- @since 1.4.14
 defaultCsrfParamName :: Text
 defaultCsrfParamName = "_token"
 
 -- | Takes a POST parameter name to lookup a CSRF token. If the value doesn't match the token stored in the session,
 -- this function throws a 'PermissionDenied' error.
 --
--- Since 1.4.14
+-- @since 1.4.14
 checkCsrfParamNamed :: MonadHandler m => Text -> m ()
 checkCsrfParamNamed paramName = do
-  valid <- hasValidCsrfParamNamed paramName
+  (valid, mParam) <- hasValidCsrfParamNamed' paramName
-  unless valid (permissionDenied csrfErrorMessage)
+  unless valid (permissionDenied $ csrfErrorMessage [CSRFParam paramName mParam])
 
 -- | Takes a POST parameter name to lookup a CSRF token, and returns whether the value matches the token stored in the session.
 --
--- Since 1.4.14
+-- @since 1.4.14
 hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool
-hasValidCsrfParamNamed paramName = do
+hasValidCsrfParamNamed paramName = fst <$> hasValidCsrfParamNamed' paramName
+
+-- | Like 'hasValidCsrfParamNamed', but also returns the param value to be used in error messages.
+hasValidCsrfParamNamed' :: MonadHandler m => Text -> m (Bool, Maybe Text)
+hasValidCsrfParamNamed' paramName = do
   mCsrfToken  <- reqToken <$> getRequest
   mCsrfParam <- lookupPostParam paramName
 
-  return $ validCsrf mCsrfToken (encodeUtf8 <$> mCsrfParam)
+  return $ (validCsrf mCsrfToken (encodeUtf8 <$> mCsrfParam), mCsrfParam)
 
 -- | Checks that a valid CSRF token is present in either the request headers or POST parameters.
 -- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error.
 --
--- Since 1.4.14
+-- @since 1.4.14
 checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m)
                        => CI S8.ByteString -- ^ The header name to lookup the CSRF token
                        -> Text -- ^ The POST parameter name to lookup the CSRF token
                        -> m ()
 checkCsrfHeaderOrParam headerName paramName = do
-  validHeader <- hasValidCsrfHeaderNamed headerName
+  (validHeader, mHeader) <- hasValidCsrfHeaderNamed' headerName
-  validParam <- hasValidCsrfParamNamed paramName
+  (validParam, mParam) <- hasValidCsrfParamNamed' paramName
   unless (validHeader || validParam) $ do
-    $logWarnS "yesod-core" csrfErrorMessage
+    let errorMessage = csrfErrorMessage $ [CSRFHeader (decodeUtf8 $ original headerName) mHeader, CSRFParam paramName mParam]
-    permissionDenied csrfErrorMessage
+    $logWarnS "yesod-core" errorMessage
+    permissionDenied errorMessage
 
 validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool
 -- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.
@@ -1469,5 +1571,25 @@ validCsrf (Just token) (Just param) = encodeUtf8 token `constEqBytes` param
 validCsrf Nothing            _param = True
 validCsrf (Just _token)     Nothing = False
 
-csrfErrorMessage :: Text
+data CSRFExpectation = CSRFHeader Text (Maybe Text) -- Key/Value
-csrfErrorMessage = "A valid CSRF token wasn't present in HTTP headers or POST parameters. Because the request could have been forged, it's been rejected altogether. Check the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection."
+                     | CSRFParam Text (Maybe Text) -- Key/Value
+
+csrfErrorMessage :: [CSRFExpectation]
+                  -> Text -- ^ Error message
+csrfErrorMessage expectedLocations = T.intercalate "\n"
+  [ "A valid CSRF token wasn't present. Because the request could have been forged, it's been rejected altogether."
+  , "If you're a developer of this site, these tips will help you debug the issue:"
+  , "- Read the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection."
+  , "- Check that your HTTP client is persisting cookies between requests, like a browser does."
+  , "- By default, the CSRF token is sent to the client in a cookie named " `mappend` (decodeUtf8 defaultCsrfCookieName) `mappend` "."
+  , "- The server is looking for the token in the following locations:\n" `mappend` T.intercalate "\n" (map csrfLocation expectedLocations)
+  ]
+
+  where csrfLocation expected = case expected of
+          CSRFHeader k v -> T.intercalate " " ["  - An HTTP header named", k, (formatValue v)]
+          CSRFParam k v -> T.intercalate " " ["  - A POST parameter named", k, (formatValue v)]
+
+        formatValue :: Maybe Text -> Text
+        formatValue maybeText = case maybeText of
+          Nothing -> "(which is not currently set)"
+          Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"]

yesod-core/Yesod/Core/Internal/TH.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Yesod.Core.Internal.TH where
 
 import Prelude hiding (exp)
@@ -15,12 +16,18 @@ import Language.Haskell.TH.Syntax
 import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
+#if MIN_VERSION_base(4,8,0)
+import Data.List (foldl', uncons)
+#else
 import Data.List (foldl')
+#endif
 #if __GLASGOW_HASKELL__ < 710
 import Control.Applicative ((<$>))
 #endif
 import Control.Monad (replicateM, void)
 import Data.Either (partitionEithers)
+import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)
+import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
 
 import Yesod.Routes.TH
 import Yesod.Routes.Parse
@@ -55,8 +62,40 @@ mkYesodSubData name = mkYesodDataGeneral name True
 
 mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
 mkYesodDataGeneral name isSub res = do
-    let (name':rest) = words name
+    let (name', rest, cxt) = case parse parseName "" name of
-    fst <$> mkYesodGeneral name' (fmap Left rest) isSub return res
+            Left err -> error $ show err
+            Right a -> a
+    fst <$> mkYesodGeneral' cxt name' (fmap Left rest) isSub return res
+
+    where
+        parseName = do
+            cxt <- option [] parseContext
+            name' <- parseWord
+            args <- many parseWord
+            spaces
+            eof
+            return ( name', args, cxt)
+
+        parseWord = do
+            spaces
+            many1 alphaNum
+
+        parseContext = try $ do
+            cxts <- parseParen parseContexts
+            spaces
+            _ <- string "=>"
+            return cxts
+
+        parseParen p = do
+            spaces
+            _ <- char '('
+            r <- p
+            spaces
+            _ <- char ')'
+            return r
+
+        parseContexts = 
+            sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
 
 -- | See 'mkYesodData'.
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
@@ -80,7 +119,23 @@ mkYesodGeneral :: String                    -- ^ foundation type
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral namestr args isSub f resS = do
+mkYesodGeneral = mkYesodGeneral' []
+
+mkYesodGeneral' :: [[String]]               -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
+               -> String                    -- ^ foundation type
+               -> [Either String [String]]  -- ^ arguments for the type
+               -> Bool                      -- ^ is this a subsite
+               -> (Exp -> Q Exp)            -- ^ unwrap handler
+               -> [ResourceTree String]
+               -> Q([Dec],[Dec])
+mkYesodGeneral' appCxt' namestr args isSub f resS = do
+    let appCxt = fmap (\(c:rest) -> 
+#if MIN_VERSION_template_haskell(2,10,0)
+            foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
+#else
+            ClassP (mkName c) $ fmap nameToType rest
+#endif
+          ) appCxt'
     mname <- lookupTypeName namestr
     arity <- case mname of
                Just name -> do
@@ -105,10 +160,13 @@ mkYesodGeneral namestr args isSub f resS = do
     vns <- replicateM (arity - length mtys) $ newName "t"
         -- Base type (site type with variables)
     let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $
-          foldr (\arg (xs,n:ns,cs) ->
+          foldr (\arg (xs,vns',cs) ->
                    case arg of
-                     Left  t  -> ( ConT (mkName t):xs, n:ns, cs )
+                     Left  t  -> 
-                     Right ts -> ( VarT n         :xs,   ns
+                                 ( nameToType t:xs, vns', cs )
+                     Right ts -> 
+                                 let (n, ns) = maybe (error "mkYesodGeneral: Should be unreachable.") id $ uncons vns' in
+                                 ( VarT n : xs, ns
                                  , fmap (\t ->
 #if MIN_VERSION_template_haskell(2,10,0)
                                                AppT (ConT $ mkName t) (VarT n)
@@ -118,11 +176,11 @@ mkYesodGeneral namestr args isSub f resS = do
                                           ) ts ++ cs )
                  ) ([],vns,[]) args
         site = foldl' AppT (ConT name) argtypes
-        res = map (fmap parseType) resS
+        res = map (fmap (parseType . dropBracket)) resS
-    renderRouteDec <- mkRenderRouteInstance site res
+    renderRouteDec <- mkRenderRouteInstance' appCxt site res
-    routeAttrsDec  <- mkRouteAttrsInstance site res
+    routeAttrsDec  <- mkRouteAttrsInstance' appCxt site res
     dispatchDec    <- mkDispatchInstance site cxt f res
-    parse <- mkParseRouteInstance site res
+    parseRoute <- mkParseRouteInstance' appCxt site res
     let rname = mkName $ "resources" ++ namestr
     eres <- lift resS
     let resourcesDec =
@@ -130,7 +188,7 @@ mkYesodGeneral namestr args isSub f resS = do
             , FunD rname [Clause [] (NormalB eres) []]
             ]
     let dataDec = concat
-            [ [parse]
+            [ [parseRoute]
             , renderRouteDec
             , [routeAttrsDec]
             , resourcesDec
@@ -138,6 +196,12 @@ mkYesodGeneral namestr args isSub f resS = do
             ]
     return (dataDec, dispatchDec)
 
+#if !MIN_VERSION_base(4,8,0)
+    where
+        uncons (h:t) = Just (h,t)
+        uncons _ = Nothing
+#endif
+
 mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
 mkMDS f rh = MkDispatchSettings
     { mdsRunHandler = rh

yesod-core/Yesod/Core/Types.hs

@@ -175,9 +175,14 @@ type BottomOfHeadAsync master
 
 type Texts = [Text]
 
--- | Wrap up a normal WAI application as a Yesod subsite.
+-- | Wrap up a normal WAI application as a Yesod subsite. Ignore parent site's middleware and isAuthorized.
 newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
 
+-- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized.
+-- 
+-- @since 1.4.34
+newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }
+
 data RunHandlerEnv site = RunHandlerEnv
     { rheRender   :: !(Route site -> [(Text, Text)] -> Text)
     , rheRoute    :: !(Maybe (Route site))
@@ -560,6 +565,14 @@ instance RenderRoute WaiSubsite where
 instance ParseRoute WaiSubsite where
     parseRoute (x, y) = Just $ WaiSubsiteRoute x y
 
+instance RenderRoute WaiSubsiteWithAuth where
+  data Route WaiSubsiteWithAuth = WaiSubsiteWithAuthRoute [Text] [(Text,Text)]
+       deriving (Show, Eq, Read, Ord)
+  renderRoute (WaiSubsiteWithAuthRoute ps qs) = (ps,qs)
+
+instance ParseRoute WaiSubsiteWithAuth where
+  parseRoute (x, y) = Just $ WaiSubsiteWithAuthRoute x y
+
 data Logger = Logger
     { loggerSet :: !LoggerSet
     , loggerDate :: !DateCacheGetter

yesod-core/Yesod/Routes/Parse.hs

@@ -10,10 +10,12 @@ module Yesod.Routes.Parse
     , parseType
     , parseTypeTree
     , TypeTree (..)
+    , dropBracket
+    , nameToType
     ) where
 
 import Language.Haskell.TH.Syntax
-import Data.Char (isUpper)
+import Data.Char (isUpper, isLower, isSpace)
 import Language.Haskell.TH.Quote
 import qualified System.IO as SIO
 import Yesod.Routes.TH
@@ -86,7 +88,7 @@ resourcesFromString =
         spaces = takeWhile (== ' ') thisLine
         (others, remainder) = parse indent otherLines'
         (this, otherLines') =
-            case takeWhile (not . isPrefixOf "--") $ words thisLine of
+            case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of
                 (pattern:rest0)
                     | Just (constr:rest) <- stripColonLast rest0
                     , Just attrs <- mapM parseAttr rest ->
@@ -102,6 +104,26 @@ resourcesFromString =
                 [] -> (id, otherLines)
                 _ -> error $ "Invalid resource line: " ++ thisLine
 
+-- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive).
+splitSpaces :: String -> [String]
+splitSpaces "" = []
+splitSpaces str = 
+    let (rest, piece) = parse $ dropWhile isSpace str in
+    piece:(splitSpaces rest)
+
+    where 
+        parse :: String -> ( String, String)
+        parse ('{':s) = fmap ('{':) $ parseBracket s
+        parse (c:s) | isSpace c = (s, [])
+        parse (c:s) = fmap (c:) $ parse s
+        parse "" = ("", "")
+
+        parseBracket :: String -> ( String, String)
+        parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str
+        parseBracket ('}':s) = fmap ('}':) $ parse s
+        parseBracket (c:s) = fmap (c:) $ parseBracket s
+        parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str
+
 piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool)
 piecesFromStringCheck s0 =
     (pieces, mmulti, check)
@@ -181,7 +203,7 @@ parseTypeTree :: String -> Maybe TypeTree
 parseTypeTree orig =
     toTypeTree pieces
   where
-    pieces = filter (not . null) $ splitOn '-' $ addDashes orig
+    pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig
     addDashes [] = []
     addDashes (x:xs) =
         front $ addDashes xs
@@ -194,7 +216,7 @@ parseTypeTree orig =
             _:y -> x : splitOn c y
             [] -> [x]
       where
-        (x, y') = break (== c) s
+        (x, y') = break c s
 
 data TypeTree = TTTerm String
               | TTApp TypeTree TypeTree
@@ -232,14 +254,18 @@ toTypeTree orig = do
             gos' (front . (t:)) xs'
 
 ttToType :: TypeTree -> Type
-ttToType (TTTerm s) = ConT $ mkName s
+ttToType (TTTerm s) = nameToType s
 ttToType (TTApp x y) = ttToType x `AppT` ttToType y
 ttToType (TTList t) = ListT `AppT` ttToType t
 
+nameToType :: String -> Type
+nameToType t@(h:_) | isLower h = VarT $ mkName t
+nameToType t = ConT $ mkName t
+
 pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
-pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
+pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)
-pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652
+pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652
-pieceFromString ('#':x) = Right $ (True, Dynamic x)
+pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x)
 
 pieceFromString ('*':'!':x) = Left (False, x)
 pieceFromString ('+':'!':x) = Left (False, x)
@@ -252,3 +278,10 @@ pieceFromString ('+':x) = Left (True, x)
 
 pieceFromString ('!':x) = Right $ (False, Static x)
 pieceFromString x = Right $ (True, Static x)
+
+dropBracket :: String -> String
+dropBracket str@('{':x) = case break (== '}') x of
+    (s, "}") -> s
+    _ -> error $ "Unclosed bracket ('{'): " ++ str
+dropBracket x = x
+

yesod-core/Yesod/Routes/TH/ParseRoute.hs

@@ -3,6 +3,7 @@
 module Yesod.Routes.TH.ParseRoute
     ( -- ** ParseRoute
       mkParseRouteInstance
+    , mkParseRouteInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -12,7 +13,10 @@ import Yesod.Routes.Class
 import Yesod.Routes.TH.Dispatch
 
 mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
-mkParseRouteInstance typ ress = do
+mkParseRouteInstance = mkParseRouteInstance' []
+
+mkParseRouteInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkParseRouteInstance' cxt typ ress = do
     cls <- mkDispatchClause
         MkDispatchSettings
             { mdsRunHandler = [|\_ _ x _ -> x|]
@@ -28,7 +32,7 @@ mkParseRouteInstance typ ress = do
         (map removeMethods ress)
     helper <- newName "helper"
     fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]
-    return $ instanceD [] (ConT ''ParseRoute `AppT` typ)
+    return $ instanceD cxt (ConT ''ParseRoute `AppT` typ)
         [ FunD 'parseRoute $ return $ Clause
             []
             (NormalB $ fixer `AppE` VarE helper)

yesod-core/Yesod/Routes/TH/RenderRoute.hs

@@ -12,6 +12,9 @@ import Yesod.Routes.TH.Types
 import Language.Haskell.TH (conT)
 #endif
 import Language.Haskell.TH.Syntax
+#if MIN_VERSION_template_haskell(2,11,0)
+import Data.Bits (xor)
+#endif
 import Data.Maybe (maybeToList)
 import Control.Monad (replicateM)
 import Data.Text (pack)
@@ -156,18 +159,28 @@ mkRenderRouteInstance' cxt typ ress = do
     cls <- mkRenderRouteClauses ress
     (cons, decs) <- mkRouteCons ress
 #if MIN_VERSION_template_haskell(2,12,0)
-    did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT clazzes)
+    did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
+    let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
 #elif MIN_VERSION_template_haskell(2,11,0)
-    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes
+    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)
+    let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
 #else
-    let did = DataInstD [] ''Route [typ] cons clazzes
+    let did = DataInstD [] ''Route [typ] cons clazzes'
+    let sds = []
 #endif
     return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)
         [ did
         , FunD (mkName "renderRoute") cls
-        ] : decs
+        ]
+        : sds ++ decs
   where
-    clazzes = [''Show, ''Eq, ''Read]
+#if MIN_VERSION_template_haskell(2,11,0)
+    clazzes standalone = if standalone `xor` null cxt then
+          clazzes'
+        else
+          []
+#endif
+    clazzes' = [''Show, ''Eq, ''Read]
 
 #if MIN_VERSION_template_haskell(2,11,0)
 notStrict :: Bang

yesod-core/Yesod/Routes/TH/RouteAttrs.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Routes.TH.RouteAttrs
     ( mkRouteAttrsInstance
+    , mkRouteAttrsInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -15,9 +16,12 @@ import Control.Applicative ((<$>))
 #endif
 
 mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
-mkRouteAttrsInstance typ ress = do
+mkRouteAttrsInstance = mkRouteAttrsInstance' []
+
+mkRouteAttrsInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkRouteAttrsInstance' cxt typ ress = do
     clauses <- mapM (goTree id) ress
-    return $ instanceD [] (ConT ''RouteAttrs `AppT` typ)
+    return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)
         [ FunD 'routeAttrs $ concat clauses
         ]
 

yesod-core/test/RouteSpec.hs

@@ -322,7 +322,7 @@ main = hspec $ do
         it "hierarchy" $ do
             routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child")
     hierarchy
-    describe "parseRouteTyoe" $ do
+    describe "parseRouteType" $ do
         let success s t = it s $ parseTypeTree s @?= Just t
             failure s = it s $ parseTypeTree s @?= Nothing
         success "Int" $ TTTerm "Int"
@@ -334,6 +334,8 @@ main = hspec $ do
         success "[Int]" $ TTList $ TTTerm "Int"
         success "Foo-Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar")
         success "Foo-Bar-Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz"
+        success "Foo Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar")
+        success "Foo Bar Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz"
 
 getRootR :: Text
 getRootR = pack "this is the root"

yesod-core/test/YesodCoreTest.hs

@@ -6,6 +6,7 @@ import YesodCoreTest.Exceptions
 import YesodCoreTest.Widget
 import YesodCoreTest.Media
 import YesodCoreTest.Links
+import YesodCoreTest.Header
 import YesodCoreTest.NoOverloadedStrings
 import YesodCoreTest.InternalRequest
 import YesodCoreTest.ErrorHandling
@@ -27,6 +28,7 @@ import Test.Hspec
 
 specs :: Spec
 specs = do
+      headerTest
       cleanPathTest
       exceptionsTest
       widgetTest

yesod-core/test/YesodCoreTest/Header.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes,
+  TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}
+
+module YesodCoreTest.Header
+  ( headerTest
+  , Widget
+  , resourcesApp
+  ) where
+
+import Data.Text (Text)
+import Network.HTTP.Types (decodePathSegments)
+import Network.Wai
+import Network.Wai.Test
+import Test.Hspec
+import Yesod.Core
+
+data App =
+  App
+
+mkYesod
+  "App"
+  [parseRoutes|
+/header1 Header1R GET
+/header2 Header2R GET
+/header3 Header3R GET
+|]
+
+instance Yesod App
+
+getHeader1R :: Handler RepPlain
+getHeader1R = do
+  addHeader "hello" "world"
+  return $ RepPlain $ toContent ("header test" :: Text)
+
+getHeader2R :: Handler RepPlain
+getHeader2R = do
+  addHeader "hello" "world"
+  replaceOrAddHeader "hello" "sibi"
+  return $ RepPlain $ toContent ("header test" :: Text)
+
+getHeader3R :: Handler RepPlain
+getHeader3R = do
+  addHeader "hello" "world"
+  addHeader "michael" "snoyman"
+  addHeader "yesod" "framework"
+  replaceOrAddHeader "yesod" "book"
+  return $ RepPlain $ toContent ("header test" :: Text)
+
+runner :: Session () -> IO ()
+runner f = toWaiApp App >>= runSession f
+
+addHeaderTest :: IO ()
+addHeaderTest =
+  runner $ do
+    res <- request defaultRequest {pathInfo = decodePathSegments "/header1"}
+    assertHeader "hello" "world" res
+
+multipleHeaderTest :: IO ()
+multipleHeaderTest =
+  runner $ do
+    res <- request defaultRequest {pathInfo = decodePathSegments "/header2"}
+    assertHeader "hello" "sibi" res
+
+header3Test :: IO ()
+header3Test = do
+  runner $ do
+    res <- request defaultRequest {pathInfo = decodePathSegments "/header3"}
+    assertHeader "hello" "world" res
+    assertHeader "michael" "snoyman" res
+    assertHeader "yesod" "book" res
+
+headerTest :: Spec
+headerTest =
+  describe "Test.Header" $ do
+    it "addHeader" addHeaderTest
+    it "multiple header" multipleHeaderTest
+    it "persist headers" header3Test

yesod-core/test/YesodCoreTest/Links.hs

@@ -25,6 +25,7 @@ mkYesod "Y" [parseRoutes|
 /route-test-2/*Vector-String RT2 GET
 /route-test-3/*Vector-(Maybe-Int) RT3 GET
 /route-test-4/#(Foo-Int-Int) RT4 GET
+/route-test-4-spaces/#{Foo Int Int} RT4Spaces GET
 |]
 
 data Vector a = Vector
@@ -64,6 +65,9 @@ getRT3 _ = return ()
 getRT4 :: Foo Int Int -> Handler ()
 getRT4 _ = return ()
 
+getRT4Spaces :: Foo Int Int -> Handler ()
+getRT4Spaces _ = return ()
+
 linksTest :: Spec
 linksTest = describe "Test.Links" $ do
       it "linkToHome" case_linkToHome

yesod-core/test/YesodCoreTest/Redirect.hs

@@ -6,7 +6,7 @@ module YesodCoreTest.Redirect
     ) where
 
 import YesodCoreTest.YesodTest
-import Yesod.Core.Handler (redirectWith, setEtag)
+import Yesod.Core.Handler (redirectWith, setEtag, setWeakEtag)
 import qualified Network.HTTP.Types as H
 
 data Y = Y
@@ -17,6 +17,7 @@ mkYesod "Y" [parseRoutes|
 /r307 R307 GET
 /rregular RRegular GET
 /etag EtagR GET
+/weak-etag WeakEtagR GET
 |]
 instance Yesod Y where approot = ApprootStatic "http://test"
 app :: Session () -> IO ()
@@ -28,12 +29,13 @@ getRootR = return ()
 postRootR :: Handler ()
 postRootR = return ()
 
-getR301, getR303, getR307, getRRegular, getEtagR :: Handler ()
+getR301, getR303, getR307, getRRegular, getEtagR, getWeakEtagR :: Handler ()
 getR301 = redirectWith H.status301 RootR
 getR303 = redirectWith H.status303 RootR
 getR307 = redirectWith H.status307 RootR
 getRRegular = redirect RootR
 getEtagR = setEtag "hello world"
+getWeakEtagR = setWeakEtag "hello world"
 
 specs :: Spec
 specs = describe "Redirect" $ do
@@ -77,6 +79,8 @@ specs = describe "Redirect" $ do
         res <- request defaultRequest { pathInfo = ["etag"] }
         assertStatus 200 res
         assertHeader "etag" "\"hello world\"" res
+      -- Note: this violates the RFC around ETag format, but is being left as is
+      -- out of concerns that it might break existing users with misbehaving clients.
       it "single, unquoted if-none-match" $ app $ do
         res <- request defaultRequest
             { pathInfo = ["etag"]
@@ -102,9 +106,27 @@ specs = describe "Redirect" $ do
             , requestHeaders = [("if-none-match", "\"foo\", \"hello world\"")]
             }
         assertStatus 304 res
-      it "ignore weak" $ app $ do
+      it "ignore weak when provided normal etag" $ app $ do
         res <- request defaultRequest
             { pathInfo = ["etag"]
             , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")]
             }
         assertStatus 200 res
+      it "weak etag" $ app $ do
+        res <- request defaultRequest
+            { pathInfo = ["weak-etag"]
+            , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")]
+            }
+        assertStatus 304 res
+      it "different if-none-match for weak etag" $ app $ do
+        res <- request defaultRequest
+            { pathInfo = ["weak-etag"]
+            , requestHeaders = [("if-none-match", "W/\"foo\"")]
+            }
+        assertStatus 200 res
+      it "ignore strong when expecting weak" $ app $ do
+        res <- request defaultRequest
+            { pathInfo = ["weak-etag"]
+            , requestHeaders = [("if-none-match", "\"hello world\", W/\"foo\"")]
+            }
+        assertStatus 200 res

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.4.31
+version:         1.4.37.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -21,7 +21,7 @@ extra-source-files:
   README.md
 
 library
-    build-depends:   base                  >= 4.6      && < 5
+    build-depends:   base                  >= 4.7      && < 5
                    , time                  >= 1.1.4
                    , wai                   >= 3.0
                    , wai-extra             >= 3.0.7
@@ -150,6 +150,7 @@ test-suite tests
                    YesodCoreTest.Auth
                    YesodCoreTest.Cache
                    YesodCoreTest.CleanPath
+                   YesodCoreTest.Header
                    YesodCoreTest.Csrf
                    YesodCoreTest.ErrorHandling
                    YesodCoreTest.Exceptions

yesod-eventsource/ChangeLog.md

@@ -1 +1,3 @@
-No changes logged yet
+## 1.4.1
+
+* Fix warnings

yesod-eventsource/yesod-eventsource.cabal

@@ -1,5 +1,5 @@
 name:            yesod-eventsource
-version:         1.4.0.1
+version:         1.4.1
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa <felipe.lessa@gmail.com>

yesod-form/ChangeLog.md

@@ -1,3 +1,30 @@
+## 1.4.16
+
+* Korean translation
+
+## 1.4.15
+
+* Added `Alternative` instance to `FormResult` to simplify handling pages with multiple forms.
+
+## 1.4.14
+
+* Added `WForm` to reduce the verbosity using monadic forms.
+* Added `wreq` and `wopt` correspondent functions for `WForm`.
+
+## 1.4.13
+
+* Fixed `textareaField` `writeHtmlEscapedChar` trim "\r"
+
+## 1.4.12
+
+* Password field does not remember its previous value
+
+## 1.4.11
+
+* Fix warnings
+* Fixed spelling errors and wording for `Yesod.Form.Functions.convertField`'s
+  documentation
+
 ## 1.4.10
 
 * Fixed `identifyForm` to properly return `FormMissing` for empty forms. [#1072](https://github.com/yesodweb/yesod/issues/1072)

yesod-form/Yesod/Form/Fields.hs

@@ -76,7 +76,7 @@ import Database.Persist.Sql (PersistField, PersistFieldSql (..))
 #if MIN_VERSION_persistent(2,5,0)
 import Database.Persist (Entity (..), SqlType (SqlString), PersistRecordBackend, PersistQueryRead)
 #else
-import Database.Persist (Entity (..), SqlType (SqlString))
+import Database.Persist (Entity (..), SqlType (SqlString), PersistEntity, PersistQuery, PersistEntityBackend)
 #endif
 import Text.HTML.SanitizeXSS (sanitizeBalance)
 import Control.Monad (when, unless)
@@ -106,6 +106,10 @@ import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput,
 
 import Yesod.Persist.Core
 
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid
+#endif
+
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
 
@@ -226,6 +230,7 @@ instance ToHtml Textarea where
         . unTextarea
       where
         -- Taken from blaze-builder and modified with newline handling.
+        writeHtmlEscapedChar '\r' = mempty
         writeHtmlEscapedChar '\n' = writeByteString "<br>"
         writeHtmlEscapedChar c    = B.writeHtmlEscapedChar c
 
@@ -267,9 +272,9 @@ $newline never
 passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
 passwordField = Field
     { fieldParse = parseHelper $ Right
-    , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
+    , fieldView = \theId name attrs _ isReq -> toWidget [hamlet|
 $newline never
-<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}">
+<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="">
 |]
     , fieldEnctype = UrlEncoded
     }

yesod-form/Yesod/Form/Functions.hs

@@ -13,7 +13,12 @@ module Yesod.Form.Functions
       -- * Applicative/Monadic conversion
     , formToAForm
     , aFormToForm
+    , mFormToWForm
+    , wFormToAForm
+    , wFormToMForm
       -- * Fields to Forms
+    , wreq
+    , wopt
     , mreq
     , mopt
     , areq
@@ -51,8 +56,9 @@ module Yesod.Form.Functions
 import Yesod.Form.Types
 import Data.Text (Text, pack)
 import Control.Arrow (second)
-import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local)
 import Control.Monad.Trans.Class
+import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST)
+import Control.Monad.Trans.Writer (runWriterT, writer)
 import Control.Monad (liftM, join)
 import Data.Byteable (constEqBytes)
 import Text.Blaze (Markup, toMarkup)
@@ -105,6 +111,58 @@ askFiles = do
     (x, _, _) <- ask
     return $ liftM snd x
 
+-- | Converts a form field into monadic form 'WForm'. This field requires a
+-- value and will return 'FormFailure' if left empty.
+--
+-- @since 1.4.14
+wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+     => Field m a           -- ^ form field
+     -> FieldSettings site  -- ^ settings for this field
+     -> Maybe a             -- ^ optional default value
+     -> WForm m (FormResult a)
+wreq f fs = mFormToWForm . mreq f fs
+
+-- | Converts a form field into monadic form 'WForm'. This field is optional,
+-- i.e.  if filled in, it returns 'Just a', if left empty, it returns
+-- 'Nothing'.  Arguments are the same as for 'wreq' (apart from type of default
+-- value).
+--
+-- @since 1.4.14
+wopt :: (MonadHandler m, HandlerSite m ~ site)
+     => Field m a           -- ^ form field
+     -> FieldSettings site  -- ^ settings for this field
+     -> Maybe (Maybe a)     -- ^ optional default value
+     -> WForm m (FormResult (Maybe a))
+wopt f fs = mFormToWForm . mopt f fs
+
+-- | Converts a monadic form 'WForm' into an applicative form 'AForm'.
+--
+-- @since 1.4.14
+wFormToAForm :: MonadHandler m
+             => WForm m (FormResult a)  -- ^ input form
+             -> AForm m a               -- ^ output form
+wFormToAForm = formToAForm . wFormToMForm
+
+-- | Converts a monadic form 'WForm' into another monadic form 'MForm'.
+--
+-- @since 1.4.14
+wFormToMForm :: (MonadHandler m, HandlerSite m ~ site)
+             => WForm m a                      -- ^ input form
+             -> MForm m (a, [FieldView site])  -- ^ output form
+wFormToMForm = mapRWST (fmap group . runWriterT)
+  where
+    group ((a, ints, enctype), views) = ((a, views), ints, enctype)
+
+-- | Converts a monadic form 'MForm' into another monadic form 'WForm'.
+--
+-- @since 1.4.14
+mFormToWForm :: (MonadHandler m, HandlerSite m ~ site)
+             => MForm m (a, FieldView site)  -- ^ input form
+             -> WForm m a                    -- ^ output form
+mFormToWForm = mapRWST $ \f -> do
+  ((a, view), ints, enctype) <- lift f
+  writer ((a, ints, enctype), [view])
+
 -- | Converts a form field into monadic form. This field requires a value
 -- and will return 'FormFailure' if left empty.
 mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
@@ -534,8 +592,8 @@ parseHelperGen f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $
 
 -- | Since a 'Field' cannot be a 'Functor', it is not obvious how to "reuse" a Field
 -- on a @newtype@ or otherwise equivalent type. This function allows you to convert
--- a @Field m a@ to a @Field m b@ assuming you provide a bidireccional
+-- a @Field m a@ to a @Field m b@ assuming you provide a bidirectional
--- convertion among the two, through the first two functions.
+-- conversion between the two, through the first two functions.
 --
 -- A simple example:
 --

yesod-form/Yesod/Form/I18n/Chinese.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Form.I18n.Chinese where
+
+import Yesod.Form.Types (FormMessage (..))
+import Data.Monoid (mappend)
+import Data.Text (Text)
+
+chineseFormMessage :: FormMessage -> Text
+chineseFormMessage (MsgInvalidInteger t) = "无效的整数: " `Data.Monoid.mappend` t
+chineseFormMessage (MsgInvalidNumber t) = "无效的数字: " `mappend` t
+chineseFormMessage (MsgInvalidEntry t) = "无效的条目: " `mappend` t
+chineseFormMessage MsgInvalidTimeFormat = "无效的时间, 必须符合HH:MM[:SS]格式"
+chineseFormMessage MsgInvalidDay = "无效的日期, 必须符合YYYY-MM-DD格式"
+chineseFormMessage (MsgInvalidUrl t) = "无效的链接: " `mappend` t
+chineseFormMessage (MsgInvalidEmail t) = "无效的邮箱地址: " `mappend` t
+chineseFormMessage (MsgInvalidHour t) = "无效的小时: " `mappend` t
+chineseFormMessage (MsgInvalidMinute t) = "无效的分钟: " `mappend` t
+chineseFormMessage (MsgInvalidSecond t) = "无效的秒: " `mappend` t
+chineseFormMessage MsgCsrfWarning = "为了防备跨站请求伪造, 请确认表格提交."
+chineseFormMessage MsgValueRequired = "此项必填"
+chineseFormMessage (MsgInputNotFound t) = "输入找不到: " `mappend` t
+chineseFormMessage MsgSelectNone = "<空>"
+chineseFormMessage (MsgInvalidBool t) = "无效的逻辑值: " `mappend` t
+chineseFormMessage MsgBoolYes = "是"
+chineseFormMessage MsgBoolNo = "否"
+chineseFormMessage MsgDelete = "删除?"

yesod-form/Yesod/Form/I18n/Korean.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Form.I18n.Korean where
+
+import Yesod.Form.Types (FormMessage (..))
+import Data.Monoid (mappend)
+import Data.Text (Text)
+
+koreanFormMessage :: FormMessage -> Text
+koreanFormMessage (MsgInvalidInteger t) = "잘못된 정수입니다: " `Data.Monoid.mappend` t
+koreanFormMessage (MsgInvalidNumber t) = "잘못된 숫자입니다: " `mappend` t
+koreanFormMessage (MsgInvalidEntry t) = "잘못된 입력입니다: " `mappend` t
+koreanFormMessage MsgInvalidTimeFormat = "잘못된 시간입니다. HH:MM[:SS] 형태로 입력하세요"
+koreanFormMessage MsgInvalidDay = "잘못된 날짜입니다. YYYY-MM-DD 형태로 입력하세요"
+koreanFormMessage (MsgInvalidUrl t) = "잘못된 URL입니다: " `mappend` t
+koreanFormMessage (MsgInvalidEmail t) = "잘못된 이메일 주소입니다: " `mappend` t
+koreanFormMessage (MsgInvalidHour t) = "잘못된 시간입니다: " `mappend` t
+koreanFormMessage (MsgInvalidMinute t) = "잘못된 분입니다: " `mappend` t
+koreanFormMessage (MsgInvalidSecond t) = "잘못된 초입니다: " `mappend` t
+koreanFormMessage MsgCsrfWarning = "CSRF공격을 방지하기 위해 양식의 입력을 확인하세요."
+koreanFormMessage MsgValueRequired = "값은 필수입니다"
+koreanFormMessage (MsgInputNotFound t) = "입력을 찾을 수 없습니다: " `mappend` t
+koreanFormMessage MsgSelectNone = "<없음>"
+koreanFormMessage (MsgInvalidBool t) = "잘못된 불(boolean)입니다: " `mappend` t
+koreanFormMessage MsgBoolYes = "예"
+koreanFormMessage MsgBoolNo = "아니오"
+koreanFormMessage MsgDelete = "삭제하시겠습니까?"

yesod-form/Yesod/Form/Input.hs

@@ -25,7 +25,7 @@ import Control.Arrow ((***))
 type DText = [Text] -> [Text]
 
 -- | Type for a form which parses a value of type @a@ with the base monad @m@
--- (usually your @Handler@). Can can compose this using its @Applicative@ instance.
+-- (usually your @Handler@). Can compose this using its @Applicative@ instance.
 newtype FormInput m a = FormInput { unFormInput :: HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a) }
 instance Monad m => Functor (FormInput m) where
     fmap a (FormInput f) = FormInput $ \c d e e' -> liftM (either Left (Right . a)) $ f c d e e'

yesod-form/Yesod/Form/Types.hs

@@ -12,6 +12,7 @@ module Yesod.Form.Types
     , FileEnv
     , Ints (..)
       -- * Form
+    , WForm
     , MForm
     , AForm (..)
       -- * Build forms
@@ -22,13 +23,14 @@ module Yesod.Form.Types
     ) where
 
 import Control.Monad.Trans.RWS (RWST)
+import Control.Monad.Trans.Writer (WriterT)
 import Data.Text (Text)
 import Data.Monoid (Monoid (..))
 import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue))
 #define Html Markup
 #define ToHtml ToMarkup
 #define toHtml toMarkup
-import Control.Applicative ((<$>), Applicative (..))
+import Control.Applicative ((<$>), Alternative (..), Applicative (..))
 import Control.Monad (liftM)
 import Control.Monad.Trans.Class
 import Data.String (IsString (..))
@@ -43,6 +45,8 @@ import Data.Foldable
 --
 -- The 'Applicative' instance will concatenate the failure messages in two
 -- 'FormResult's.
+-- The 'Alternative' instance will choose 'FormFailure' before 'FormSuccess',
+-- and 'FormMissing' last of all.
 data FormResult a = FormMissing
                   | FormFailure [Text]
                   | FormSuccess a
@@ -78,6 +82,16 @@ instance Data.Traversable.Traversable FormResult where
       FormFailure errs -> pure (FormFailure errs)
       FormMissing -> pure FormMissing
 
+-- | @since 1.4.15
+instance Alternative FormResult where
+    empty = FormMissing
+
+    FormFailure e    <|> _             = FormFailure e
+    _                <|> FormFailure e = FormFailure e
+    FormSuccess s    <|> FormSuccess _ = FormSuccess s
+    FormMissing      <|> result        = result
+    result           <|> FormMissing   = result
+
 -- | The encoding type required by a form. The 'ToHtml' instance produces values
 -- that can be inserted directly into HTML.
 data Enctype = UrlEncoded | Multipart
@@ -102,6 +116,29 @@ instance Show Ints where
 type Env = Map.Map Text [Text]
 type FileEnv = Map.Map Text [FileInfo]
 
+-- | 'MForm' variant stacking a 'WriterT'. The following code example using a
+-- monadic form 'MForm':
+--
+-- > formToAForm $ do
+-- >   (field1F, field1V) <- mreq textField MsgField1 Nothing
+-- >   (field2F, field2V) <- mreq (checkWith field1F textField) MsgField2 Nothing
+-- >   (field3F, field3V) <- mreq (checkWith field1F textField) MsgField3 Nothing
+-- >   return
+-- >     ( MyForm <$> field1F <*> field2F <*> field3F
+-- >     , [field1V, field2V, field3V]
+-- >     )
+--
+-- Could be rewritten as follows using 'WForm':
+--
+-- > wFormToAForm $ do
+-- >   field1F <- wreq textField MsgField1 Nothing
+-- >   field2F <- wreq (checkWith field1F textField) MsgField2 Nothing
+-- >   field3F <- wreq (checkWith field1F textField) MsgField3 Nothing
+-- >   return $ MyForm <$> field1F <*> field2F <*> field3F
+--
+-- @since 1.4.14
+type WForm m a = MForm (WriterT [FieldView (HandlerSite m)] m) a
+
 type MForm m a = RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang])
     Enctype

yesod-form/yesod-form.cabal

@@ -1,5 +1,5 @@
 name:            yesod-form
-version:         1.4.10
+version:         1.4.16
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -68,6 +68,8 @@ library
                      Yesod.Form.I18n.Russian
                      Yesod.Form.I18n.Dutch
                      Yesod.Form.I18n.Spanish
+                     Yesod.Form.I18n.Chinese
+                     Yesod.Form.I18n.Korean
                      -- FIXME Yesod.Helpers.Crud
     ghc-options:     -Wall
 

yesod-persistent/ChangeLog.md

@@ -1,3 +1,11 @@
+## 1.4.3
+
+* Fix overly powerful constraints on get404 and getBy404.
+
+## 1.4.2
+
+* Fix warnings
+
 ## 1.4.1.1
 
 * Fix build failure with older persistent versions [#1324](https://github.com/yesodweb/yesod/issues/1324)

yesod-persistent/Yesod/Persist/Core.hs

@@ -134,7 +134,7 @@ respondSourceDB ctype = respondSource ctype . runDBSource
 
 -- | Get the given entity by ID, or return a 404 not found if it doesn't exist.
 #if MIN_VERSION_persistent(2,5,0)
-get404 :: (MonadIO m, PersistStore backend, PersistRecordBackend val backend)
+get404 :: (MonadIO m, PersistStoreRead backend, PersistRecordBackend val backend)
        => Key val
        -> ReaderT backend m val
 #else
@@ -151,7 +151,7 @@ get404 key = do
 -- | Get the given entity by unique key, or return a 404 not found if it doesn't
 --   exist.
 #if MIN_VERSION_persistent(2,5,0)
-getBy404 :: (PersistUnique backend, PersistRecordBackend val backend, MonadIO m)
+getBy404 :: (PersistUniqueRead backend, PersistRecordBackend val backend, MonadIO m)
          => Unique val
          -> ReaderT backend m (Entity val)
 #else

yesod-persistent/yesod-persistent.cabal

@@ -1,5 +1,5 @@
 name:            yesod-persistent
-version:         1.4.1.1
+version:         1.4.3
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -16,8 +16,8 @@ extra-source-files: README.md ChangeLog.md
 library
     build-depends:   base                      >= 4        && < 5
                    , yesod-core                >= 1.4.0    && < 1.5
-                   , persistent                >= 2.1      && < 2.7
+                   , persistent                >= 2.1      && < 2.8
-                   , persistent-template       >= 2.1      && < 2.7
+                   , persistent-template       >= 2.1      && < 2.8
                    , transformers              >= 0.2.2
                    , blaze-builder
                    , conduit

yesod-static/ChangeLog.md

@@ -1,3 +1,17 @@
+## 1.5.3.1
+
+* Switch to cryptonite
+
+## 1.5.3
+
+* Add `staticFilesMap` function
+* Add `staticFilesMergeMap` function
+
+## 1.5.2
+
+* Fix test case for CRLF line endings
+* Fix warnings
+
 ## 1.5.1.1
 
 * Fix test suite compilation

yesod-static/Yesod/Static.hs

@@ -51,6 +51,8 @@ module Yesod.Static
       -- * Template Haskell helpers
     , staticFiles
     , staticFilesList
+    , staticFilesMap
+    , staticFilesMergeMap
     , publicFiles
       -- * Hashing
     , base64md5
@@ -62,6 +64,7 @@ module Yesod.Static
     ) where
 
 import System.Directory
+import qualified System.FilePath as FP
 import Control.Monad
 import Data.FileEmbed (embedDir)
 
@@ -78,7 +81,7 @@ import Crypto.Hash (MD5, Digest)
 import Control.Monad.Catch (MonadThrow)
 import Control.Monad.Trans.State
 
-import qualified Data.Byteable as Byteable
+import qualified Data.ByteArray as ByteArray
 import qualified Data.ByteString.Base64
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
@@ -246,7 +249,7 @@ staticFiles dir = mkStaticFiles dir
 -- files @\"static\/js\/jquery.js\"@ and
 -- @\"static\/css\/normalize.css\"@, you would use:
 --
--- > staticFilesList \"static\" [\"js\/jquery.js\", \"css\/normalize.css\"]
+-- > staticFilesList "static" ["js/jquery.js", "css/normalize.css"]
 --
 -- This can be useful when you have a very large number of static
 -- files, but only need to refer to a few of them from Haskell.
@@ -273,6 +276,53 @@ staticFilesList dir fs =
 publicFiles :: FilePath -> Q [Dec]
 publicFiles dir = mkStaticFiles' dir False
 
+-- | Similar to 'staticFilesList', but takes a mapping of
+-- unmunged names to fingerprinted file names.
+--
+-- @since 1.5.3
+staticFilesMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec]
+staticFilesMap fp m = mkStaticFilesList' fp (map splitBoth mapList) True
+  where
+    splitBoth (k, v) = (split k, split v)
+    mapList = M.toList m
+    split :: FilePath -> [String]
+    split [] = []
+    split x =
+        let (a, b) = break (== '/') x
+         in a : split (drop 1 b)
+
+-- | Similar to 'staticFilesMergeMap', but also generates identifiers
+-- for all files in the specified directory that don't have a
+-- fingerprinted version.
+--
+-- @since 1.5.3
+staticFilesMergeMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec]
+staticFilesMergeMap fp m = do
+  fs <- qRunIO $ getFileListPieces fp
+  let filesList = map FP.joinPath fs
+      mergedMapList = M.toList $ foldl' (checkedInsert invertedMap) m filesList
+  mkStaticFilesList' fp (map splitBoth mergedMapList) True
+  where
+    splitBoth (k, v) = (split k, split v)
+    swap (x, y) = (y, x)
+    mapList = M.toList m
+    invertedMap = M.fromList $ map swap mapList
+    split :: FilePath -> [String]
+    split [] = []
+    split x =
+        let (a, b) = break (== '/') x
+         in a : split (drop 1 b)
+    -- We want to keep mappings for all files that are pre-fingerprinted,
+    -- so this function checks against all of the existing fingerprinted files and
+    -- only inserts a new mapping if it's not a fingerprinted file.
+    checkedInsert
+      :: M.Map FilePath FilePath -- inverted dictionary
+      -> M.Map FilePath FilePath -- accumulating state
+      -> FilePath
+      -> M.Map FilePath FilePath
+    checkedInsert iDict st p = if M.member p iDict
+      then st
+      else M.insert p p st
 
 mkHashMap :: FilePath -> IO (M.Map FilePath S8.ByteString)
 mkHashMap dir = do
@@ -330,7 +380,16 @@ mkStaticFilesList
     -> [[String]] -- ^ list of files to create identifiers for
     -> Bool     -- ^ append checksum query parameter
     -> Q [Dec]
-mkStaticFilesList fp fs makeHash = do
+mkStaticFilesList fp fs makeHash = mkStaticFilesList' fp (zip fs fs) makeHash
+
+mkStaticFilesList'
+    :: FilePath -- ^ static directory
+    -> [([String], [String])] -- ^ list of files to create identifiers for, where
+                              -- the first argument of the tuple is the identifier
+                              -- alias and the second is the actual file name
+    -> Bool     -- ^ append checksum query parameter
+    -> Q [Dec]
+mkStaticFilesList' fp fs makeHash = do
     concat `fmap` mapM mkRoute fs
   where
     replace' c
@@ -338,8 +397,8 @@ mkStaticFilesList fp fs makeHash = do
         | 'a' <= c && c <= 'z' = c
         | '0' <= c && c <= '9' = c
         | otherwise = '_'
-    mkRoute f = do
+    mkRoute (alias, f) = do
-        let name' = intercalate "_" $ map (map replace') f
+        let name' = intercalate "_" $ map (map replace') alias
             routeName = mkName $
                 case () of
                     ()
@@ -361,7 +420,7 @@ mkStaticFilesList fp fs makeHash = do
 
 base64md5File :: FilePath -> IO String
 base64md5File = fmap (base64 . encode) . hashFile
-    where encode d = Byteable.toBytes (d :: Digest MD5)
+    where encode d = ByteArray.convert (d :: Digest MD5)
 
 base64md5 :: L.ByteString -> String
 base64md5 lbs =
@@ -369,7 +428,7 @@ base64md5 lbs =
           $ runIdentity
           $ sourceList (L.toChunks lbs) $$ sinkHash
   where
-    encode d = Byteable.toBytes (d :: Digest MD5)
+    encode d = ByteArray.convert (d :: Digest MD5)
 
 base64 :: S.ByteString -> String
 base64 = map tr

yesod-static/yesod-static.cabal

@@ -1,5 +1,5 @@
 name:            yesod-static
-version:         1.5.1.1
+version:         1.5.3.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -44,8 +44,9 @@ library
                    , unix-compat           >= 0.2
                    , conduit               >= 0.5
                    , conduit-extra
-                   , cryptohash-conduit    >= 0.1
+                   , cryptonite-conduit    >= 0.1
-                   , cryptohash            >= 0.11
+                   , cryptonite            >= 0.11
+                   , memory
                    , data-default
                    , mime-types            >= 0.1
                    , hjsmin
@@ -112,8 +113,9 @@ test-suite tests
                    , http-types
                    , unix-compat
                    , conduit
-                   , cryptohash-conduit
+                   , cryptonite-conduit
-                   , cryptohash
+                   , cryptonite
+                   , memory
                    , data-default
                    , mime-types
                    , hjsmin

yesod-test/ChangeLog.md

@@ -1,3 +1,21 @@
+## 1.5.8
+* Added implicit parameter HasCallStack to assertions.
+[#1421](https://github.com/yesodweb/yesod/pull/1421)
+
+## 1.5.7
+
+* Add clickOn.
+[#1408](https://github.com/yesodweb/yesod/pull/1408)
+
+## 1.5.6
+
+* Add assertNotEq.
+[#1375](https://github.com/yesodweb/yesod/pull/1375)
+
+## 1.5.5
+
+* Fix warnings
+
 ## 1.5.4.1
 
 * Compilation fix for GHC 7.8

yesod-test/Yesod/Test.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ConstraintKinds #-}
 
 {-|
 Yesod.Test is a pragmatic framework for testing web applications built
@@ -62,6 +64,7 @@ module Yesod.Test
     , setRequestBody
     , RequestBuilder
     , setUrl
+    , clickOn
 
     -- *** Adding fields by label
     -- | Yesod can auto generate field names, so you are never sure what
@@ -86,6 +89,7 @@ module Yesod.Test
 
     -- * Assertions
     , assertEqual
+    , assertNotEq
     , assertEqualNoShow
     , assertEq
 
@@ -148,6 +152,16 @@ import Data.Time.Clock (getCurrentTime)
 import Control.Applicative ((<$>))
 import Text.Show.Pretty (ppShow)
 import Data.Monoid (mempty)
+#if MIN_VERSION_base(4,9,0)
+import GHC.Stack (HasCallStack)
+#elif MIN_VERSION_base(4,8,1)
+import GHC.Stack (CallStack)
+type HasCallStack = (?callStack :: CallStack)
+#else
+import GHC.Exts (Constraint)
+type HasCallStack = (() :: Constraint)
+#endif
+
 
 -- | The state used in a single test case defined using 'yit'
 --
@@ -325,28 +339,39 @@ htmlQuery = htmlQuery' yedResponse []
 
 -- | Asserts that the two given values are equal.
 --
--- In case they are not equal, error mesasge includes the two values.
+-- In case they are not equal, error message includes the two values.
 --
 -- @since 1.5.2
-assertEq :: (Eq a, Show a) => String -> a -> a -> YesodExample site ()
+assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
 assertEq m a b =
   liftIO $ HUnit.assertBool msg (a == b)
   where msg = "Assertion: " ++ m ++ "\n" ++
               "First argument:  " ++ ppShow a ++ "\n" ++
               "Second argument: " ++ ppShow b ++ "\n"
 
+-- | Asserts that the two given values are not equal.
+--
+-- In case they are equal, error mesasge includes the values.
+--
+-- @since 1.5.6
+assertNotEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
+assertNotEq m a b =
+  liftIO $ HUnit.assertBool msg (a /= b)
+  where msg = "Assertion: " ++ m ++ "\n" ++
+              "Both arguments:  " ++ ppShow a ++ "\n"
+
 {-# DEPRECATED assertEqual "Use assertEq instead" #-}
-assertEqual :: (Eq a) => String -> a -> a -> YesodExample site ()
+assertEqual :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site ()
 assertEqual = assertEqualNoShow
 
 -- | Asserts that the two given values are equal.
 --
 -- @since 1.5.2
-assertEqualNoShow :: (Eq a) => String -> a -> a -> YesodExample site ()
+assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site ()
 assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b)
 
 -- | Assert the last response status is as expected.
-statusIs :: Int -> YesodExample site ()
+statusIs :: HasCallStack => Int -> YesodExample site ()
 statusIs number = withResponse $ \ SResponse { simpleStatus = s } ->
   liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat
     [ "Expected status was ", show number
@@ -354,7 +379,7 @@ statusIs number = withResponse $ \ SResponse { simpleStatus = s } ->
     ]
 
 -- | Assert the given header key/value pair was returned.
-assertHeader :: CI BS8.ByteString -> BS8.ByteString -> YesodExample site ()
+assertHeader :: HasCallStack => CI BS8.ByteString -> BS8.ByteString -> YesodExample site ()
 assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->
   case lookup header h of
     Nothing -> failure $ T.pack $ concat
@@ -374,7 +399,7 @@ assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->
         ]
 
 -- | Assert the given header was not included in the response.
-assertNoHeader :: CI BS8.ByteString -> YesodExample site ()
+assertNoHeader :: HasCallStack => CI BS8.ByteString -> YesodExample site ()
 assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->
   case lookup header h of
     Nothing -> return ()
@@ -387,14 +412,14 @@ assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->
 
 -- | Assert the last response is exactly equal to the given text. This is
 -- useful for testing API responses.
-bodyEquals :: String -> YesodExample site ()
+bodyEquals :: HasCallStack => String -> YesodExample site ()
 bodyEquals text = withResponse $ \ res ->
   liftIO $ HUnit.assertBool ("Expected body to equal " ++ text) $
     (simpleBody res) == encodeUtf8 (TL.pack text)
 
 -- | Assert the last response has the given text. The check is performed using the response
 -- body in full text form.
-bodyContains :: String -> YesodExample site ()
+bodyContains :: HasCallStack => String -> YesodExample site ()
 bodyContains text = withResponse $ \ res ->
   liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $
     (simpleBody res) `contains` text
@@ -402,7 +427,7 @@ bodyContains text = withResponse $ \ res ->
 -- | Assert the last response doesn't have the given text. The check is performed using the response
 -- body in full text form.
 -- @since 1.5.3
-bodyNotContains :: String -> YesodExample site ()
+bodyNotContains :: HasCallStack => String -> YesodExample site ()
 bodyNotContains text = withResponse $ \ res ->
   liftIO $ HUnit.assertBool ("Expected body not to contain " ++ text) $
     not $ contains (simpleBody res) text
@@ -412,7 +437,7 @@ contains a b = DL.isInfixOf b (TL.unpack $ decodeUtf8 a)
 
 -- | Queries the HTML using a CSS selector, and all matched elements must contain
 -- the given string.
-htmlAllContain :: Query -> String -> YesodExample site ()
+htmlAllContain :: HasCallStack => Query -> String -> YesodExample site ()
 htmlAllContain query search = do
   matches <- htmlQuery query
   case matches of
@@ -424,7 +449,7 @@ htmlAllContain query search = do
 -- element contains the given string.
 --
 -- Since 0.3.5
-htmlAnyContain :: Query -> String -> YesodExample site ()
+htmlAnyContain :: HasCallStack => Query -> String -> YesodExample site ()
 htmlAnyContain query search = do
   matches <- htmlQuery query
   case matches of
@@ -437,7 +462,7 @@ htmlAnyContain query search = do
 -- inverse of htmlAnyContains).
 --
 -- Since 1.2.2
-htmlNoneContain :: Query -> String -> YesodExample site ()
+htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site ()
 htmlNoneContain query search = do
   matches <- htmlQuery query
   case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of
@@ -447,7 +472,7 @@ htmlNoneContain query search = do
 
 -- | Performs a CSS query on the last response and asserts the matched elements
 -- are as many as expected.
-htmlCount :: Query -> Int -> YesodExample site ()
+htmlCount :: HasCallStack => Query -> Int -> YesodExample site ()
 htmlCount query count = do
   matches <- fmap DL.length $ htmlQuery query
   liftIO $ flip HUnit.assertBool (matches == count)
@@ -818,6 +843,25 @@ setUrl url' = do
         , rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery)
         }
 
+
+-- | Click on a link defined by a CSS query
+--
+-- ==== __ Examples__
+--
+-- > get "/foobar"
+-- > clickOn "a#idofthelink"
+--
+-- @since 1.5.7 
+clickOn :: Yesod site => Query -> YesodExample site ()
+clickOn query = do
+  withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res ->
+    case findAttributeBySelector (simpleBody res) query "href" of
+      Left err -> failure $ query <> " did not parse: " <> T.pack (show err)
+      Right [[match]] -> get match
+      Right matches -> failure $ "Expected exactly one match for clickOn: got " <> T.pack (show matches)
+
+
+
 -- | Simple way to set HTTP request body
 --
 -- ==== __ Examples__

yesod-test/Yesod/Test/TransversingCSS.hs

@@ -10,16 +10,16 @@ and it returns a list of the HTML fragments that matched the given query.
 Only a subset of the CSS spec is currently supported:
 
  * By tag name: /table td a/
- 
+
  * By class names: /.container .content/
 
  * By Id: /#oneId/
 
  * By attribute: /[hasIt]/, /[exact=match]/, /[contains*=text]/, /[starts^=with]/, /[ends$=with]/
- 
+
  * Union: /a, span, p/
- 
+
- * Immediate children: /div > p/ 
+ * Immediate children: /div > p/
 
  * Get jiggy with it: /div[data-attr=yeah] > .mon, .foo.bar div, #oneThing/
 
@@ -27,6 +27,7 @@ Only a subset of the CSS spec is currently supported:
 
 module Yesod.Test.TransversingCSS (
   findBySelector,
+  findAttributeBySelector,
   HtmlLBS,
   Query,
   -- * For HXT hackers
@@ -41,7 +42,7 @@ where
 
 import Yesod.Test.CssQuery
 import qualified Data.Text as T
-import Control.Applicative ((<$>), (<*>))
+import qualified Control.Applicative
 import Text.XML
 import Text.XML.Cursor
 import qualified Data.ByteString.Lazy as L
@@ -58,9 +59,30 @@ type HtmlLBS = L.ByteString
 --
 -- * Right: List of matching Html fragments.
 findBySelector :: HtmlLBS -> Query -> Either String [String]
-findBySelector html query = (\x -> map (renderHtml . toHtml . node) . runQuery x)
+findBySelector html query =
-    Control.Applicative.<$> (Right $ fromDocument $ HD.parseLBS html)
+  map (renderHtml . toHtml . node) Control.Applicative.<$> findCursorsBySelector html query
-    Control.Applicative.<*> parseQuery query
+
+-- | Perform a css 'Query' on 'Html'. Returns Either
+--
+-- * Left: Query parse error.
+--
+-- * Right: List of matching Cursors
+findCursorsBySelector :: HtmlLBS -> Query -> Either String [Cursor]
+findCursorsBySelector html query =
+  runQuery (fromDocument $ HD.parseLBS html)
+       Control.Applicative.<$> parseQuery query
+
+-- | Perform a css 'Query' on 'Html'. Returns Either
+--
+-- * Left: Query parse error.
+--
+-- * Right: List of matching Cursors
+--
+-- @since 1.5.7
+findAttributeBySelector :: HtmlLBS -> Query -> T.Text -> Either String [[T.Text]]
+findAttributeBySelector html query attr =
+  map (laxAttribute attr) Control.Applicative.<$> findCursorsBySelector html query
+
 
 -- Run a compiled query on Html, returning a list of matching Html fragments.
 runQuery :: Cursor -> [[SelectorGroup]] -> [Cursor]

yesod-test/test/main.hs

@@ -34,6 +34,7 @@ import Data.ByteString.Lazy.Char8 ()
 import qualified Data.Map as Map
 import qualified Text.HTML.DOM as HD
 import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415)
+import Control.Exception.Lifted(SomeException, try)
 
 parseQuery_ :: Text -> [[SelectorGroup]]
 parseQuery_ = either error id . parseQuery
@@ -149,6 +150,18 @@ main = hspec $ do
                     addToken
                 statusIs 200
                 bodyEquals "12345"
+            yit "labels WForm" $ do
+                get ("/wform" :: Text)
+                statusIs 200
+
+                request $ do
+                    setMethod "POST"
+                    setUrl ("/wform" :: Text)
+                    byLabel "Some WLabel" "12345"
+                    fileByLabel "Some WFile" "test/main.hs" "text/plain"
+                    addToken
+                statusIs 200
+                bodyEquals "12345"
             yit "finding html" $ do
                 get ("/html" :: Text)
                 statusIs 200
@@ -169,6 +182,16 @@ main = hspec $ do
                     addToken_ "body"
                 statusIs 200
                 bodyEquals "12345"
+            yit "can follow a link via clickOn" $ do
+              get ("/htmlWithLink" :: Text)
+              clickOn "a#thelink"
+              statusIs 200
+              bodyEquals "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>"
+
+              get ("/htmlWithLink" :: Text)
+              (bad :: Either SomeException ()) <- try (clickOn "a#nonexistentlink")
+              assertEq "bad link" (isLeft bad) True
+
 
         ydescribe "utf8 paths" $ do
             yit "from path" $ do
@@ -323,9 +346,20 @@ app = liteApp $ do
         case mfoo of
             FormSuccess (foo, _) -> return $ toHtml foo
             _ -> defaultLayout widget
+    onStatic "wform" $ dispatchTo $ do
+        ((mfoo, widget), _) <- runFormPost $ renderDivs $ wFormToAForm $ do
+          field1F <- wreq textField "Some WLabel" Nothing
+          field2F <- wreq fileField "Some WFile" Nothing
+
+          return $ (,) Control.Applicative.<$> field1F <*> field2F
+        case mfoo of
+            FormSuccess (foo, _) -> return $ toHtml foo
+            _                    -> defaultLayout widget
     onStatic "html" $ dispatchTo $
         return ("<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>" :: Text)
 
+    onStatic "htmlWithLink" $ dispatchTo $
+        return ("<html><head><title>A link</title></head><body><a href=\"/html\" id=\"thelink\">Link!</a></body></html>" :: Text)
     onStatic "labels" $ dispatchTo $
         return ("<html><label><input type='checkbox' name='fooname' id='foobar'>Foo Bar</label></html>" :: Text)
 

yesod-test/yesod-test.cabal

@@ -1,5 +1,5 @@
 name:               yesod-test
-version:            1.5.4.1
+version:            1.5.8
 license:            MIT
 license-file:       LICENSE
 author:             Nubis <nubis@woobiz.com.ar>
@@ -58,7 +58,7 @@ test-suite test
                           , containers
                           , html-conduit
                           , yesod-core
-                          , yesod-form
+                          , yesod-form >= 1.4.14
                           , text
                           , wai
                           , lifted-base

yesod-websockets/ChangeLog.md

@@ -1,3 +1,7 @@
+## 0.2.6
+
+* Fix warnings
+
 ## 0.2.5
 
 * Allow to start websockets with custom ConnectionOptions with `webSocketsOptions` and `webSocketsOptionsWith`

yesod-websockets/sample.hs

@@ -3,10 +3,10 @@ import Yesod.Core
 import Yesod.WebSockets
 import qualified Data.Text.Lazy as TL
 import Control.Monad (forever)
-import Control.Monad.Trans.Reader
 import Control.Concurrent (threadDelay)
 import Data.Time
-import Conduit
+import Data.Conduit
+import qualified Data.Conduit.List
 
 data App = App
 
@@ -25,7 +25,7 @@ timeSource = forever $ do
 getHomeR :: Handler Html
 getHomeR = do
     webSockets $ race_
-        (sourceWS $$ mapC TL.toUpper =$ sinkWSText)
+        (sourceWS $$ Data.Conduit.List.map TL.toUpper =$ sinkWSText)
         (timeSource $$ sinkWSText)
     defaultLayout $
         toWidget
@@ -43,6 +43,9 @@ getHomeR = do
                 conn.onmessage = function(e) {
                     document.write("<p>" + e.data + "</p>");
                 };
+                conn.onclose = function () {
+                    document.write("<p>Connection Closed</p>");
+                };
             |]
 
 main :: IO ()

yesod-websockets/yesod-websockets.cabal

@@ -1,5 +1,5 @@
 name:                yesod-websockets
-version:             0.2.5
+version:             0.2.6
 synopsis:            WebSockets support for Yesod
 description:         WebSockets support for Yesod
 homepage:            https://github.com/yesodweb/yesod

yesod/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.4.5
+
+* Fix warnings
+
 ## 1.4.4
 
 * Reduce dependencies

yesod/yesod.cabal

@@ -1,5 +1,5 @@
 name:            yesod
-version:         1.4.4
+version:         1.4.5
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>