Actually export the new options (#1825)

* actually export the new options

* bump version number, update changelog

.github/workflows/tests.yml

@@ -15,20 +15,25 @@ jobs:
       matrix:
         os: [ubuntu-latest, macos-latest, windows-latest]
         args:
-        - "--resolver nightly"
+        #- "--resolver nightly"
+        - "--resolver nightly-2022-02-11"
+        - "--resolver lts-18"
         - "--resolver lts-16"
         - "--resolver lts-14"
         - "--resolver lts-12"
         - "--resolver lts-11"
-        - "--stack-yaml stack-persistent-211.yaml"
         # Bugs in GHC make it crash too often to be worth running
         exclude:
           - os: windows-latest
             args: "--resolver nightly"
-          - os: windows-latest
+          - os: macos-latest
             args: "--resolver lts-16"
-          - os: windows-latest
-            args: "--stack-yaml stack-persistent-211.yaml"
+          - os: macos-latest
+            args: "--resolver lts-14"
+          - os: macos-latest
+            args: "--resolver lts-12"
+          - os: macos-latest
+            args: "--resolver lts-11"
 
     steps:
       - name: Clone project
@@ -47,6 +52,5 @@ jobs:
         shell: bash
         run: |
             set -ex
-            stack upgrade
             stack --version
             stack test --fast --no-terminal ${{ matrix.args }}

.gitignore

@@ -25,3 +25,5 @@ tarballs/
 
 # OS X
 .DS_Store
+*.yaml.lock
+dist-newstyle/

cabal.project

@@ -0,0 +1,15 @@
+packages:
+  yesod-core
+  yesod-static
+  yesod-persistent
+  yesod-newsfeed
+  yesod-form
+  yesod-form-multi
+  yesod-auth
+  yesod-auth-oauth
+  yesod-sitemap
+  yesod-test
+  yesod-bin
+  yesod
+  yesod-eventsource
+  yesod-websockets

demo/subsite/WikiRoutes.hs

@@ -21,7 +21,7 @@ data Wiki = Wiki
     }
 
 -- | A typeclass that all master sites that want a Wiki must implement. A
--- master must be able to render form messages, as we use yesod-forms for
+-- master must be able to render form messages, as we use yesod-form for
 -- processing user input.
 class (RenderMessage master FormMessage, Yesod master) => YesodWiki master where
     -- | Write protection. By default, no protection.

stack-persistent-211.yaml

@@ -1,20 +0,0 @@
-resolver: lts-16.20
-packages:
-- ./yesod-core
-- ./yesod-static
-- ./yesod-persistent
-- ./yesod-newsfeed
-- ./yesod-form
-- ./yesod-form-multi
-- ./yesod-auth
-- ./yesod-auth-oauth
-- ./yesod-sitemap
-- ./yesod-test
-- ./yesod-bin
-- ./yesod
-- ./yesod-eventsource
-- ./yesod-websockets
-extra-deps:
-- persistent-2.11.0.1@rev:0
-- persistent-template-2.9.1.0@rev:0
-- persistent-sqlite-2.11.0.0@rev:0

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-15.5
+resolver: lts-18.3
 packages:
 - ./yesod-core
 - ./yesod-static
@@ -14,3 +14,6 @@ packages:
 - ./yesod
 - ./yesod-eventsource
 - ./yesod-websockets
+
+extra-deps:
+- attoparsec-aeson-2.1.0.0

stack.yaml.lock

@@ -3,10 +3,17 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/lock_files
 
-packages: []
+packages:
+- completed:
+    hackage: attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
+    pantry-tree:
+      sha256: 294c3a8a19a7ddad58097e18c624c6b34894b3c4a4cc490759cb31d842db242a
+      size: 114
+  original:
+    hackage: attoparsec-aeson-2.1.0.0
 snapshots:
 - completed:
-    size: 491372
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/5.yaml
-    sha256: 1b549cfff328040c382a70a84a2087aac8dab6d778bf92f32a93a771a1980dfc
-  original: lts-15.5
+    sha256: 694573e96dca34db5636edb1fe6c96bb233ca0f9fb96c1ead1671cdfa9bd73e9
+    size: 585603
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/3.yaml
+  original: lts-18.3

yesod-auth-oauth/ChangeLog.md

@@ -1,3 +1,13 @@
+# ChangeLog for yesod-auth-oauth
+
+## 1.6.1
+
+* Allow newer GHC
+
+## 1.6.0.3
+
+* Allow yesod-form 1.7
+
 ## 1.6.0.2
 
 * Remove unnecessary deriving of Typeable

yesod-auth-oauth/Yesod/Auth/OAuth.hs

@@ -18,7 +18,6 @@ import           Control.Applicative      as A ((<$>), (<*>))
 import           Control.Arrow            ((***))
 import           UnliftIO.Exception
 import           Control.Monad.IO.Class
-import           UnliftIO                 (MonadUnliftIO)
 import           Data.ByteString          (ByteString)
 import           Data.Maybe
 import           Data.Text                (Text)
@@ -53,14 +52,9 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
     oauthSessionName = "__oauth_token_secret"
 
     dispatch
-      :: ( MonadHandler m
-         , master ~ HandlerSite m
-         , Auth ~ SubHandlerSite m
-         , MonadUnliftIO m
-         )
-      => Text
+      :: Text
       -> [Text]
-      -> m TypedContent
+      -> AuthHandler master TypedContent
     dispatch "GET" ["forward"] = do
         render <- getUrlRender
         tm <- getRouteToParent

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

@@ -1,5 +1,6 @@
+cabal-version:   >= 1.10
 name:            yesod-auth-oauth
-version:         1.6.0.2
+version:         1.6.1
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
@@ -7,21 +8,21 @@ maintainer:      Michael Litchard
 synopsis:        OAuth Authentication for Yesod.
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-auth-oauth>
 extra-source-files: README.md ChangeLog.md
 
 library
-    build-depends:   authenticate-oauth      >= 1.5       && < 1.7
+    default-language: Haskell2010
+    build-depends:   authenticate-oauth      >= 1.5       && < 1.8
                    , base                    >= 4.10      && < 5
                    , bytestring              >= 0.9.1.4
                    , text                    >= 0.7
                    , unliftio
                    , yesod-auth              >= 1.6       && < 1.7
                    , yesod-core              >= 1.6       && < 1.7
-                   , yesod-form              >= 1.6       && < 1.7
+                   , yesod-form              >= 1.6       && < 1.8
     exposed-modules: Yesod.Auth.OAuth
     ghc-options:     -Wall
 

yesod-auth/ChangeLog.md

@@ -1,5 +1,33 @@
 # ChangeLog for yesod-auth
 
+## 1.6.11.2
+
+* Add support for aeson 2.2 [#1820](https://github.com/yesodweb/yesod/pull/1820)
+
+## 1.6.11.1
+
+* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
+
+## 1.6.11
+
+* Add support for aeson 2
+
+## 1.6.10.5
+
+* Fix German translations of AuthMessage [#1741](https://github.com/yesodweb/yesod/pull/1741)
+
+## 1.6.10.4
+
+* Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737)
+
+## 1.6.10.3
+
+* Relax bounds for yesod-form 1.7
+
+## 1.6.10.2
+
+* Relax bounds for persistent 2.12
+
 ## 1.6.10.1
 
 * Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)

yesod-auth/README.md

@@ -6,6 +6,7 @@ BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available
 from Hackage as well. If you've written such an add-on, please notify me so
 that it can be added to this description.
 
+* [yesod-auth-oauth2](https://hackage.haskell.org/package/yesod-auth-oauth2): Library to authenticate with OAuth 2.0.
 * [yesod-auth-account](http://hackage.haskell.org/package/yesod-auth-account): An account authentication plugin for Yesod
 * [yesod-auth-hashdb](http://www.stackage.org/package/yesod-auth-hashdb): The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security.
-* [yesod-auth-bcrypt](https://github.com/ollieh/yesod-auth-bcrypt/): An alternative to the HashDB module.
+* [yesod-auth-bcrypt](https://hackage.haskell.org/package/yesod-auth-bcrypt): An alternative to the HashDB module.

yesod-auth/Yesod/Auth.hs

@@ -52,7 +52,6 @@ import Control.Monad.Trans.Maybe
 import UnliftIO                      (withRunInIO, MonadUnliftIO)
 
 import Yesod.Auth.Routes
-import Data.Aeson hiding (json)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
 import           Data.Text (Text)
@@ -74,6 +73,7 @@ import Control.Exception (Exception)
 import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
 import qualified Control.Monad.Trans.Writer    as Writer
 import Control.Monad (void)
+import Data.Kind (Type)
 
 type AuthRoute = Route Auth
 
@@ -452,7 +452,7 @@ $nothing
     <p>Not logged in.
 |]
     jsonCreds creds =
-        Object $ Map.fromList
+        toJSON $ Map.fromList
             [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
             ]
 
@@ -533,7 +533,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
     -- > AuthEntity MySite ~ User
     --
     -- @since 1.2.0
-    type AuthEntity master :: *
+    type AuthEntity master :: Type
     type AuthEntity master = KeyEntity (AuthId master)
 
     getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)

yesod-auth/Yesod/Auth/Dummy.hs

@@ -1,8 +1,9 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
 -- | Provides a dummy authentication module that simply lets a user specify
 -- their identifier. This is not intended for real world use, just for
 -- testing. This plugin supports form submissions via JSON (since 1.6.8).
@@ -35,12 +36,12 @@ module Yesod.Auth.Dummy
     ( authDummy
     ) where
 
-import Yesod.Auth
-import Yesod.Form (runInputPost, textField, ireq)
-import Yesod.Core
-import Data.Text (Text)
-import Data.Aeson.Types (Result(..), Parser)
+import           Data.Aeson.Types (Parser, Result (..))
 import qualified Data.Aeson.Types as A (parseEither, withObject)
+import           Data.Text        (Text)
+import           Yesod.Auth
+import           Yesod.Core
+import           Yesod.Form       (ireq, runInputPost, textField)
 
 identParser :: Value -> Parser Text
 identParser = A.withObject "Ident" (.: "ident")
@@ -49,6 +50,7 @@ authDummy :: YesodAuth m => AuthPlugin m
 authDummy =
     AuthPlugin "dummy" dispatch login
   where
+    dispatch :: Text -> [Text] -> AuthHandler m TypedContent
     dispatch "POST" [] = do
         (jsonResult :: Result Value) <- parseCheckJsonBody
         eIdent <- case jsonResult of

yesod-auth/Yesod/Auth/Email.hs

@@ -31,16 +31,16 @@
 -- = Using JSON Endpoints
 --
 -- We are assuming that you have declared auth route as follows
--- 
+--
 -- @
 --    /auth AuthR Auth getAuth
 -- @
--- 
+--
 -- If you are using a different route, then you have to adjust the
 -- endpoints accordingly.
 --
 --     * Registration
--- 
+--
 -- @
 --       Endpoint: \/auth\/page\/email\/register
 --       Method: POST
@@ -49,9 +49,9 @@
 --                      "password": "myStrongPassword" (optional)
 --                  }
 -- @
--- 
+--
 --     * Forgot password
---  
+--
 -- @
 --       Endpoint: \/auth\/page\/email\/forgot-password
 --       Method: POST
@@ -59,16 +59,16 @@
 -- @
 --
 --     * Login
---  
+--
 -- @
 --       Endpoint: \/auth\/page\/email\/login
 --       Method: POST
---       JSON Data: { 
+--       JSON Data: {
 --                      "email": "myemail@domain.com",
 --                      "password": "myStrongPassword"
 --                  }
 -- @
--- 
+--
 --     * Set new password
 --
 -- @
@@ -117,28 +117,30 @@ module Yesod.Auth.Email
     , defaultRegisterHelper
     ) where
 
-import           Yesod.Auth
-import qualified Yesod.Auth.Message       as Msg
-import           Yesod.Core
-import           Yesod.Form
-import qualified Yesod.Auth.Util.PasswordStore as PS
-import           Control.Applicative      ((<$>), (<*>))
-import qualified Crypto.Hash              as H
-import qualified Crypto.Nonce             as Nonce
-import           Data.ByteString.Base16   as B16
-import           Data.Text                (Text)
-import qualified Data.Text                as TS
-import qualified Data.Text                as T
-import           Data.Text.Encoding       (decodeUtf8With, encodeUtf8)
-import qualified Data.Text.Encoding       as TE
-import           Data.Text.Encoding.Error (lenientDecode)
-import           Data.Time                (addUTCTime, getCurrentTime)
-import           Safe                     (readMay)
-import           System.IO.Unsafe         (unsafePerformIO)
+import           Control.Applicative           ((<$>), (<*>))
+import qualified Crypto.Hash                   as H
+import qualified Crypto.Nonce                  as Nonce
+import           Data.Aeson.Types              (Parser, Result (..), parseMaybe,
+                                                withObject, (.:?))
+import           Data.ByteArray                (convert)
+import           Data.ByteString.Base16        as B16
+import           Data.Maybe                    (isJust)
+import           Data.Text                     (Text)
+import qualified Data.Text                     as T
+import qualified Data.Text                     as TS
+import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8)
+import qualified Data.Text.Encoding            as TE
+import           Data.Text.Encoding.Error      (lenientDecode)
+import           Data.Time                     (addUTCTime, getCurrentTime)
+import           Safe                          (readMay)
+import           System.IO.Unsafe              (unsafePerformIO)
 import qualified Text.Email.Validate
-import           Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
-import           Data.Maybe (isJust)
-import Data.ByteArray (convert)
+import           Yesod.Auth
+import qualified Yesod.Auth.Message            as Msg
+import qualified Yesod.Auth.Util.PasswordStore as PS
+import           Yesod.Core
+import           Yesod.Core.Types              (TypedContent (TypedContent))
+import           Yesod.Form
 
 loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
 loginR = PluginR "email" ["login"]
@@ -240,7 +242,7 @@ class ( YesodAuth site
     --
     -- @since 1.4.20
     hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
-    hashAndSaltPassword = liftIO . saltPass
+    hashAndSaltPassword password = liftIO $ saltPass password
 
     -- | Verify a password matches the stored password for the given account.
     --
@@ -432,13 +434,14 @@ authEmail :: (YesodAuthEmail m) => AuthPlugin m
 authEmail =
     AuthPlugin "email" dispatch emailLoginHandler
   where
+    dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent
     dispatch "GET" ["register"] = getRegisterR >>= sendResponse
     dispatch "POST" ["register"] = postRegisterR >>= sendResponse
     dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse
     dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse
     dispatch "GET" ["verify", eid, verkey] =
         case fromPathPiece eid of
-            Nothing -> notFound
+            Nothing   -> notFound
             Just eid' -> getVerifyR eid' verkey False >>= sendResponse
     dispatch "GET" ["verify", eid, verkey, hasSetPass] =
         case fromPathPiece eid of
@@ -576,7 +579,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                  _ -> do
                      (creds :: Result Value) <- parseCheckJsonBody
                      return $ case creds of
-                                  Error _ -> Nothing
+                                  Error _     -> Nothing
                                   Success val -> parseMaybe parseRegister val
 
     let eidentifier = case creds of
@@ -589,7 +592,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
 
     let mpass = case (forgotPassword, creds) of
                     (False, Just (_, mp)) -> mp
-                    _ -> Nothing
+                    _                     -> Nothing
 
     case eidentifier of
       Left failMsg -> loginErrorMessageI dest failMsg
@@ -620,7 +623,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                     then sendConfirmationEmail creds
                     else case emailPreviouslyRegisteredResponse identifier of
                       Just response -> response
-                      Nothing -> sendConfirmationEmail creds
+                      Nothing       -> sendConfirmationEmail creds
               where sendConfirmationEmail (lid, _, verKey, email) = do
                       render <- getUrlRender
                       tp <- getRouteToParent
@@ -739,7 +742,7 @@ postLoginR = do
                      _ -> do
                        (creds :: Result Value) <- parseCheckJsonBody
                        case creds of
-                         Error _ -> return Nothing
+                         Error _     -> return Nothing
                          Success val -> return $ parseMaybe parseCreds val
 
     case midentifier of
@@ -779,8 +782,8 @@ getPasswordR = do
     maid <- maybeAuthId
     case maid of
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-        Just _ -> do
-            needOld <- maybe (return True) needOldPassword maid
+        Just aid -> do
+            needOld <- needOldPassword aid
             setPasswordHandler needOld
 
 -- | Default implementation of 'setPasswordHandler'.
@@ -870,7 +873,7 @@ postPasswordR = do
     maid <- maybeAuthId
     (creds :: Result Value) <- parseCheckJsonBody
     let jcreds = case creds of
-                   Error _ -> Nothing
+                   Error _     -> Nothing
                    Success val -> parseMaybe parsePassword val
     let doJsonParsing = isJust jcreds
     case maid of
@@ -882,7 +885,7 @@ postPasswordR = do
                 res <- runInputPostResult $ ireq textField "current"
                 let fcurrent = case res of
                                  FormSuccess currentPass -> Just currentPass
-                                 _ -> Nothing
+                                 _                       -> Nothing
                 let current = if doJsonParsing
                               then getThird jcreds
                               else fcurrent
@@ -901,9 +904,9 @@ postPasswordR = do
   where
     msgOk = Msg.PassUpdated
     getThird (Just (_,_,t)) = t
-    getThird Nothing = Nothing
+    getThird Nothing        = Nothing
     getNewConfirm (Just (a,b,_)) = Just (a,b)
-    getNewConfirm _ = Nothing
+    getNewConfirm _              = Nothing
     confirmPassword aid tm jcreds = do
         res <- runInputPostResult $ (,)
             <$> ireq textField "new"
@@ -912,7 +915,7 @@ postPasswordR = do
                     then getNewConfirm jcreds
                     else case res of
                            FormSuccess res' -> Just res'
-                           _ -> Nothing
+                           _                -> Nothing
         case creds of
           Nothing -> loginErrorMessageI setpassR Msg.PassMismatch
           Just (new, confirm) ->
@@ -932,7 +935,7 @@ postPasswordR = do
 
                      mr <- getMessageRender
                      selectRep $ do
-                         provideRep $ 
+                         provideRep $
                             fmap asHtml $ redirect $ afterPasswordRoute y
                          provideJsonMessage (mr msgOk)
 

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -53,55 +53,61 @@ module Yesod.Auth.GoogleEmail2
     , pid
     ) where
 
-import           Yesod.Auth               (Auth, AuthPlugin (AuthPlugin),
-                                           AuthRoute, Creds (Creds),
-                                           Route (PluginR), YesodAuth,
-                                           runHttpRequest, setCredsRedirect,
-                                           logoutDest, AuthHandler)
-import qualified Yesod.Auth.Message       as Msg
-import           Yesod.Core               (HandlerSite, MonadHandler,
-                                           TypedContent, getRouteToParent,
-                                           getUrlRender, invalidArgs,
-                                           liftIO, lookupGetParam,
-                                           lookupSession, notFound, redirect,
-                                           setSession, whamlet, (.:),
-                                           addMessage, getYesod,
-                                           toHtml, liftSubHandler)
+import           Yesod.Auth                  (Auth, AuthHandler,
+                                              AuthPlugin (AuthPlugin),
+                                              AuthRoute, Creds (Creds),
+                                              Route (PluginR), YesodAuth,
+                                              logoutDest, runHttpRequest,
+                                              setCredsRedirect)
+import qualified Yesod.Auth.Message          as Msg
+import           Yesod.Core                  (HandlerSite, MonadHandler,
+                                              TypedContent, addMessage,
+                                              getRouteToParent, getUrlRender,
+                                              getYesod, invalidArgs, liftIO,
+                                              liftSubHandler, lookupGetParam,
+                                              lookupSession, notFound, redirect,
+                                              setSession, toHtml, whamlet, (.:))
 
 
-import           Blaze.ByteString.Builder (fromByteString, toByteString)
-import           Control.Applicative      ((<$>), (<*>))
-import           Control.Arrow            (second)
-import           Control.Monad            (unless, when)
-import           Control.Monad.IO.Class   (MonadIO)
-import qualified Crypto.Nonce             as Nonce
-import           Data.Aeson               ((.:?))
-import qualified Data.Aeson               as A
+import           Blaze.ByteString.Builder    (fromByteString, toByteString)
+import           Control.Applicative         ((<$>), (<*>))
+import           Control.Arrow               (second)
+import           Control.Monad               (unless, when)
+import           Control.Monad.IO.Class      (MonadIO)
+import qualified Crypto.Nonce                as Nonce
+import           Data.Aeson                  ((.:?))
+import qualified Data.Aeson                  as A
 #if MIN_VERSION_aeson(1,0,0)
-import qualified Data.Aeson.Text          as A
+import qualified Data.Aeson.Text             as A
 #else
-import qualified Data.Aeson.Encode        as A
+import qualified Data.Aeson.Encode           as A
 #endif
-import           Data.Aeson.Parser        (json')
-import           Data.Aeson.Types         (FromJSON (parseJSON), parseEither,
-                                           parseMaybe, withObject, withText)
+import           Data.Aeson.Parser           (json')
+import           Data.Aeson.Types            (FromJSON (parseJSON), parseEither,
+                                              parseMaybe, withObject, withText)
 import           Data.Conduit
-import           Data.Conduit.Attoparsec  (sinkParser)
-import qualified Data.HashMap.Strict      as M
-import           Data.Maybe               (fromMaybe)
-import           Data.Monoid              (mappend)
-import           Data.Text                (Text)
-import qualified Data.Text                as T
-import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)
-import qualified Data.Text.Lazy           as TL
-import qualified Data.Text.Lazy.Builder   as TL
-import           Network.HTTP.Client      (Manager, requestHeaders,
-                                           responseBody, urlEncodedBody)
-import qualified Network.HTTP.Client      as HTTP
+import           Data.Conduit.Attoparsec     (sinkParser)
+import           Data.Maybe                  (fromMaybe)
+import           Data.Monoid                 (mappend)
+import           Data.Text                   (Text)
+import qualified Data.Text                   as T
+import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)
+import qualified Data.Text.Lazy              as TL
+import qualified Data.Text.Lazy.Builder      as TL
+import           Network.HTTP.Client         (Manager, requestHeaders,
+                                              responseBody, urlEncodedBody)
+import qualified Network.HTTP.Client         as HTTP
 import           Network.HTTP.Client.Conduit (Request, bodyReaderSource)
-import           Network.HTTP.Conduit (http)
-import           Network.HTTP.Types       (renderQueryText)
-import           System.IO.Unsafe         (unsafePerformIO)
+import           Network.HTTP.Conduit        (http)
+import           Network.HTTP.Types          (renderQueryText)
+import           System.IO.Unsafe            (unsafePerformIO)
+
+#if MIN_VERSION_aeson(2, 0, 0)
+import qualified Data.Aeson.Key
+import qualified Data.Aeson.KeyMap
+#else
+import qualified Data.HashMap.Strict         as M
+#endif
 
 
 -- | Plugin identifier. This is used to identify the plugin used for
@@ -239,7 +245,7 @@ authPlugin storeToken clientID clientSecret =
         value <- makeHttpRequest req
         token@(Token accessToken' tokenType') <-
             case parseEither parseJSON value of
-                Left e -> error e
+                Left e  -> error e
                 Right t -> return t
 
         unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType'
@@ -247,16 +253,18 @@ authPlugin storeToken clientID clientSecret =
         -- User's access token is saved for further access to API
         when storeToken $ setSession accessTokenKey accessToken'
 
-        personValue <- makeHttpRequest =<< personValueRequest token
+        personValReq <- personValueRequest token
+        personValue <- makeHttpRequest personValReq
+
         person <- case parseEither parseJSON personValue of
-                Left e -> error e
+                Left e  -> error e
                 Right x -> return x
 
         email <-
             case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of
                 [e] -> return e
-                [] -> error "No account email"
-                x -> error $ "Too many account emails: " ++ show x
+                []  -> error "No account email"
+                x   -> error $ "Too many account emails: " ++ show x
         setCredsRedirect $ Creds pid email $ allPersonInfo personValue
 
     dispatch _ _ = notFound
@@ -450,16 +458,16 @@ data RelationshipStatus = Single              -- ^ Person is single
 
 instance FromJSON RelationshipStatus where
     parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of
-                  "single"                    -> Single
-                  "in_a_relationship"         -> InRelationship
-                  "engaged"                   -> Engaged
-                  "married"                   -> Married
-                  "its_complicated"           -> Complicated
-                  "open_relationship"         -> OpenRelationship
-                  "widowed"                   -> Widowed
-                  "in_domestic_partnership"   -> DomesticPartnership
-                  "in_civil_union"            -> CivilUnion
-                  _                           -> RelationshipStatus t
+                  "single"                  -> Single
+                  "in_a_relationship"       -> InRelationship
+                  "engaged"                 -> Engaged
+                  "married"                 -> Married
+                  "its_complicated"         -> Complicated
+                  "open_relationship"       -> OpenRelationship
+                  "widowed"                 -> Widowed
+                  "in_domestic_partnership" -> DomesticPartnership
+                  "in_civil_union"          -> CivilUnion
+                  _                         -> RelationshipStatus t
 
 --------------------------------------------------------------------------------
 -- | The URI of the person's profile photo.
@@ -585,9 +593,19 @@ instance FromJSON EmailType where
         _         -> EmailType t
 
 allPersonInfo :: A.Value -> [(Text, Text)]
-allPersonInfo (A.Object o) = map enc $ M.toList o
-    where enc (key, A.String s) = (key, s)
-          enc (key, v) = (key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
+allPersonInfo (A.Object o) = map enc $ mapToList o
+  where
+    enc (key, A.String s) = (keyToText key, s)
+    enc (key, v) = (keyToText key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
+
+#if MIN_VERSION_aeson(2, 0, 0)
+    keyToText = Data.Aeson.Key.toText
+    mapToList = Data.Aeson.KeyMap.toList
+#else
+    keyToText = id
+    mapToList = M.toList
+#endif
+
 allPersonInfo _ = []
 
 

yesod-auth/Yesod/Auth/Hardcoded.hs

@@ -131,10 +131,9 @@ module Yesod.Auth.Hardcoded
   , loginR )
   where
 
-import           Yesod.Auth          (AuthPlugin (..), AuthRoute,
+import           Yesod.Auth          (AuthHandler, AuthPlugin (..), AuthRoute,
                                       Creds (..), Route (..), YesodAuth,
-                                      loginErrorMessageI, setCredsRedirect,
-                                      AuthHandler)
+                                      loginErrorMessageI, setCredsRedirect)
 import qualified Yesod.Auth.Message  as Msg
 import           Yesod.Core
 import           Yesod.Form          (ireq, runInputPost, textField)
@@ -159,8 +158,9 @@ authHardcoded :: YesodAuthHardcoded m => AuthPlugin m
 authHardcoded =
   AuthPlugin "hardcoded" dispatch loginWidget
   where
+    dispatch :: YesodAuthHardcoded m => Text -> [Text] -> AuthHandler m TypedContent
     dispatch "POST" ["login"] = postLoginR >>= sendResponse
-    dispatch _ _ = notFound
+    dispatch _ _              = notFound
     loginWidget toMaster = do
       request <- getRequest
       [whamlet|

yesod-auth/Yesod/Auth/Message.hs

@@ -282,13 +282,13 @@ germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"
 germanMessage LoginOpenID = "Login via OpenID"
 germanMessage LoginGoogle = "Login via Google"
 germanMessage LoginYahoo = "Login via Yahoo"
-germanMessage Email = "Email"
-germanMessage UserName = "Benutzername" -- FIXME by Google Translate "user name"
+germanMessage Email = "E-Mail"
+germanMessage UserName = "Benutzername"
 germanMessage Password = "Passwort"
 germanMessage CurrentPassword = "Aktuelles Passwort"
 germanMessage Register = "Registrieren"
 germanMessage RegisterLong = "Neuen Account registrieren"
-germanMessage EnterEmail = "Bitte die e-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."
+germanMessage EnterEmail = "Bitte die E-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."
 germanMessage ConfirmationEmailSentTitle = "Bestätigung verschickt."
 germanMessage (ConfirmationEmailSent email) =
     "Eine Bestätigung wurde an " `mappend`
@@ -308,24 +308,23 @@ germanMessage ConfirmPass = "Bestätigen"
 germanMessage PassMismatch = "Die Passwörter stimmen nicht überein"
 germanMessage PassUpdated = "Passwort überschrieben"
 germanMessage Facebook = "Login über Facebook"
-germanMessage LoginViaEmail = "Login via e-Mail"
+germanMessage LoginViaEmail = "Login via E-Mail"
 germanMessage InvalidLogin = "Ungültiger Login"
 germanMessage NowLoggedIn = "Login erfolgreich"
-germanMessage LoginTitle = "Log In"
+germanMessage LoginTitle = "Anmelden"
 germanMessage PleaseProvideUsername = "Bitte Nutzername angeben"
 germanMessage PleaseProvidePassword = "Bitte Passwort angeben"
-germanMessage NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben"
-germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter"
+germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben"
+germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter"
 germanMessage PasswordResetTitle = "Passwort zurücksetzen"
-germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"
-germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen"
-germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann."
+germanMessage ProvideIdentifier = "E-Mail-Adresse oder Nutzername"
+germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen"
+germanMessage PasswordResetPrompt = "Nach Einhabe der E-Mail-Adresse oder des Nutzernamen wird eine E-Mail zugesendet mit welcher das Passwort zurückgesetzt werden kann."
 germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"
--- TODO
-germanMessage i@(IdentifierNotFound _) = englishMessage i
-germanMessage Logout = "Ausloggen" -- FIXME by Google Translate
-germanMessage LogoutTitle = "Ausloggen" -- FIXME by Google Translate
-germanMessage AuthError = "Autorisierungsfehler" -- FIXME by Google Translate
+germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO
+germanMessage Logout = "Abmelden"
+germanMessage LogoutTitle = "Abmelden"
+germanMessage AuthError = "Fehler beim Anmelden"
 
 frenchMessage :: AuthMessage -> Text
 frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"

yesod-auth/yesod-auth.cabal

@@ -1,6 +1,6 @@
 cabal-version:   >=1.10
 name:            yesod-auth
-version:         1.6.10.1
+version:         1.6.11.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -23,6 +23,7 @@ library
     default-language: Haskell2010
     build-depends:   base                    >= 4.10      && < 5
                    , aeson                   >= 0.7
+                   , attoparsec-aeson        >= 2.1
                    , authenticate            >= 1.3.4
                    , base16-bytestring
                    , base64-bytestring
@@ -44,7 +45,7 @@ library
                    , http-types
                    , memory
                    , nonce                   >= 1.0.2     && < 1.1
-                   , persistent              >= 2.8       && < 2.12
+                   , persistent              >= 2.8
                    , random                  >= 1.0.0.2
                    , safe
                    , shakespeare
@@ -57,7 +58,7 @@ library
                    , unordered-containers
                    , wai                     >= 1.4
                    , yesod-core              >= 1.6       && < 1.7
-                   , yesod-form              >= 1.6       && < 1.7
+                   , yesod-form              >= 1.6       && < 1.8
                    , yesod-persistent        >= 1.6
 
     if flag(network-uri)

yesod-bin/AddHandler.hs

@@ -9,13 +9,18 @@ import Data.List  (isPrefixOf, isSuffixOf, stripPrefix)
 import Data.Maybe (fromMaybe, listToMaybe)
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
-#if MIN_VERSION_Cabal(2, 2, 0)
+#if MIN_VERSION_Cabal(3, 7, 0)
+import Distribution.Simple.PackageDescription (readGenericPackageDescription)
+#elif MIN_VERSION_Cabal(2, 2, 0)
 import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
 #elif MIN_VERSION_Cabal(2, 0, 0)
 import Distribution.PackageDescription.Parse (readGenericPackageDescription)
 #else
 import Distribution.PackageDescription.Parse (readPackageDescription)
 #endif
+#if MIN_VERSION_Cabal(3, 6, 0)
+import Distribution.Utils.Path
+#endif
 import Distribution.PackageDescription.Configuration (flattenPackageDescription)
 import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)
 import Distribution.Verbosity (normal)
@@ -247,4 +252,8 @@ getSrcDir cabal = do
 #endif
     let buildInfo = allBuildInfo pd
         srcDirs = concatMap hsSourceDirs buildInfo
+#if MIN_VERSION_Cabal(3, 6, 0)
+    return $ maybe "." getSymbolicPath $ listToMaybe srcDirs
+#else
     return $ fromMaybe "." $ listToMaybe srcDirs
+#endif

yesod-bin/ChangeLog.md

@@ -1,5 +1,21 @@
 # ChangeLog for yesod-bin
 
+## 1.6.2.2
+
+* Support Cabal 3.8 [#1769](https://github.com/yesodweb/yesod/pull/1769)
+
+## 1.6.2.1
+
+* Support Cabal 3.6 [#1754](https://github.com/yesodweb/yesod/pull/1754)
+
+## 1.6.2
+
+* aeson 2.0
+
+## 1.6.1
+
+Added command line options `cert` and `key` to allow TLS certificate and key files to be passed to `yesod devel` [#1717](https://github.com/yesodweb/yesod/pull/1717)
+
 ## 1.6.0.6
 
 Fix the `add-handler` subcommand to support both the old default routes filename (`routes`) and the new one (`routes.yesodroutes`) [#1688](https://github.com/yesodweb/yesod/pull/1688)

yesod-bin/Devel.hs

@@ -28,6 +28,9 @@ import           Data.String                           (fromString)
 import           Data.Time                             (getCurrentTime)
 import qualified Distribution.Package                  as D
 import qualified Distribution.PackageDescription       as D
+#if MIN_VERSION_Cabal(3,8,0)
+import qualified Distribution.Simple.PackageDescription as D
+#endif
 #if MIN_VERSION_Cabal(2, 2, 0)
 import qualified Distribution.PackageDescription.Parsec as D
 #else
@@ -56,7 +59,7 @@ import           Network.Wai                           (requestHeaderHost,
                                                         responseLBS)
 import           Network.Wai.Handler.Warp              (defaultSettings, runSettings,
                                                         setPort, setHost)
-import           Network.Wai.Handler.WarpTLS           (runTLS,
+import           Network.Wai.Handler.WarpTLS           (runTLS, tlsSettings,
                                                         tlsSettingsMemory)
 import           Network.Wai.Parse                     (parseHttpAccept)
 import           Say
@@ -126,6 +129,7 @@ data DevelOpts = DevelOpts
       , proxyTimeout    :: Int
       , useReverseProxy :: Bool
       , develHost       :: Maybe String
+      , cert            :: Maybe (FilePath, FilePath)
       } deriving (Show, Eq)
 
 -- | Run a reverse proxy from the develPort and develTlsPort ports to
@@ -135,7 +139,7 @@ reverseProxy :: DevelOpts -> TVar Int -> IO ()
 reverseProxy opts appPortVar = do
     manager <- newManager $ managerSetProxy noProxy tlsManagerSettings
     let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")]
-        sayV = when (verbose opts) . sayString    
+        sayV = when (verbose opts) . sayString
     let onExc _ req
             | maybe False (("application/json" `elem`) . parseHttpAccept)
                 (lookup "accept" $ requestHeaders req) =
@@ -170,10 +174,12 @@ reverseProxy opts appPortVar = do
                 manager
         defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings
         runProxyTls port app = do
-          let cert = $(embedFile "certificate.pem")
-              key = $(embedFile "key.pem")
-              tlsSettings = tlsSettingsMemory cert key
-          runTLS tlsSettings (setPort port defaultSettings') $ \req send -> do
+          let certDef = $(embedFile "certificate.pem")
+              keyDef = $(embedFile "key.pem")
+              theSettings = case cert opts of
+                Nothing -> tlsSettingsMemory certDef keyDef
+                Just (c,k) -> tlsSettings c k
+          runTLS theSettings (setPort port defaultSettings') $ \req send -> do
             let req' = req
                     { requestHeaders
                         = ("X-Forwarded-Proto", "https")

yesod-bin/Keter.hs

@@ -1,10 +1,16 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 module Keter
     ( keter
     ) where
 
 import Data.Yaml
+
+#if MIN_VERSION_aeson(2, 0, 0)
+import qualified Data.Aeson.KeyMap as Map
+#else
 import qualified Data.HashMap.Strict as Map
+#endif
 import qualified Data.Text as T
 import System.Environment (getEnvironment)
 import System.Exit

yesod-bin/main.hs

@@ -30,12 +30,13 @@ data Command = Init [String]
              | Build { buildExtraArgs   :: [String] }
              | Touch
              | Devel { develSuccessHook :: Maybe String
-                     , develExtraArgs    :: [String]
+                     , develExtraArgs   :: [String]
                      , develPort        :: Int
                      , develTlsPort     :: Int
                      , proxyTimeout     :: Int
                      , noReverseProxy   :: Bool
                      , develHost        :: Maybe String
+                     , cert             :: Maybe (FilePath, FilePath)
                      }
              | DevelSignal
              | Test
@@ -90,6 +91,7 @@ main = do
                              , proxyTimeout = proxyTimeout
                              , useReverseProxy = not noReverseProxy
                              , develHost    = develHost
+                             , cert         = cert
                              } develExtraArgs
     DevelSignal     -> develSignal
   where
@@ -167,6 +169,11 @@ develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "C
                             <> help "Disable reverse proxy" )
                      <*> optStr (long "host" <> metavar "HOST"
                             <> help "Host interface to bind to; IP address, '*' for all interfaces, '*4' for IP4, '*6' for IP6")
+                     <*> optional ( (,)
+                            <$> strOption (long "cert" <> metavar "CERT"
+                                   <> help "Path to TLS certificate file, requires that --key is also defined")
+                            <*> strOption (long "key" <> metavar "KEY"
+                                   <> help "Path to TLS key file, requires that --cert is also defined") )
 
 extraStackArgs :: Parser [String]
 extraStackArgs = many (strOption ( long "extra-stack-arg" <> short 'e' <> metavar "ARG"

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.6.0.6
+version:         1.6.2.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -35,7 +35,7 @@ executable             yesod
                      , directory          >= 1.2.1
                      , file-embed
                      , filepath           >= 1.1
-                     , fsnotify           >= 0.0          && < 0.4
+                     , fsnotify
                      , http-client        >= 0.4.7
                      , http-client-tls
                      , http-reverse-proxy >= 0.4
@@ -61,6 +61,7 @@ executable             yesod
                      , warp-tls           >= 3.0.1
                      , yaml               >= 0.8          && < 0.12
                      , zlib               >= 0.5
+                     , aeson
 
     ghc-options:       -Wall -threaded -rtsopts
     main-is:           main.hs

yesod-core/ChangeLog.md

@@ -1,5 +1,93 @@
 # ChangeLog for yesod-core
 
+## 1.6.25.1
+
+* Export the options that were created in 1.6.25.0 [#1825](https://github.com/yesodweb/yesod/pull/1825)
+
+## 1.6.25.0
+
+* Add an options structure that allows the user to set which instances will be derived for a routes structure. [#1819](https://github.com/yesodweb/yesod/pull/1819)
+
+## 1.6.24.5
+
+* Support Aeson 2.2 [#1818](https://github.com/yesodweb/yesod/pull/1818)
+
+## 1.6.24.4
+
+* Fix test-suite compilation error for GHC >= 9.0.1 [#1812](https://github.com/yesodweb/yesod/pull/1812)
+
+## 1.6.24.3
+
+* Fix subsite-to-subsite dispatch [#1805](https://github.com/yesodweb/yesod/pull/1805)
+
+## 1.6.24.2
+
+* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
+
+## 1.6.24.1
+
+* Adapt to removal of `ListT` from transformers-0.6. [#1796](https://github.com/yesodweb/yesod/pull/1796)
+
+## 1.6.24.0
+
+* Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772).
+
+## 1.6.23.1
+
+* Fix typo in creation of the description `<meta>` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766)
+
+## 1.6.23
+
+* Add idempotent versions of `setDescription`, `setDescriptionI`. These functions
+  have odd behaviour when called multiple times, so they are now warned against.
+  This can't be a silent change - if you want to switch to the new functions, make
+  sure your layouts are updated to use `pageDescription` as well as `pageTitle`.
+  [#1765](https://github.com/yesodweb/yesod/pull/1765)
+
+## 1.6.22.1
+
++ Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756)
+
+## 1.6.22.0
+
+* Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745)
+* Add instances for `ToContent Void`, `ToTypedContent Void`. [#1752](https://github.com/yesodweb/yesod/pull/1752)
+* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753)
+* Support template-haskell 2.18 [#1754](https://github.com/yesodweb/yesod/pull/1754)
+
+## 1.6.21.0
+
+* Export `Yesod.Core.Dispatch.defaultGen` so that users may reuse it for their own `YesodRunnerEnv`s [#1734](https://github.com/yesodweb/yesod/pull/1734)
+
+## 1.6.20.2
+
+* Fix compatibility with template-haskell 2.17 [#1729](https://github.com/yesodweb/yesod/pull/1729)
+
+## 1.6.20.1
+
+* Throw an error in `breadcrumbs` if the trail of breadcrumbs is circular. [#1727](https://github.com/yesodweb/yesod/issues/1727)
+
+## 1.6.20
+
+* Generate CSRF tokens using a secure entropy source [#1726](https://github.com/yesodweb/yesod/pull/1726)
+* Change semantics of `yreGen` and `defaultGen`
+
+## 1.6.19.0
+
+* Change order of priority in `languages`[#1721](https://github.com/yesodweb/yesod/pull/1721)
+
+## 1.6.18.8
+
+* Fix test suite for wai-extra change around vary header
+
+## 1.6.18.7
+
+* Fix functions generating Open Graph metadata[#1709](https://github.com/yesodweb/yesod/pull/1709)
+
+## 1.6.18.6
+
+* Update documentation from `HandlerT` to `HandlerFor` [#1703](https://github.com/yesodweb/yesod/pull/1703)
+
 ## 1.6.18.5
 
 Document `ErrorResponse` [#1698](https://github.com/yesodweb/yesod/pull/1698)

yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Yesod.Core.Class.Breadcrumbs where
 
 import Yesod.Core.Handler
@@ -15,7 +16,7 @@ class YesodBreadcrumbs site where
 
 -- | Gets the title of the current page and the hierarchy of parent pages,
 -- along with their respective titles.
-breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)])
+breadcrumbs :: (YesodBreadcrumbs site, Show (Route site), Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)])
 breadcrumbs = do
     x <- getCurrentRoute
     case x of
@@ -26,6 +27,8 @@ breadcrumbs = do
             return (title, z)
   where
     go back Nothing = return back
-    go back (Just this) = do
-        (title, next) <- breadcrumb this
-        go ((this, title) : back) next
+    go back (Just this)
+      | this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this
+      | otherwise = do
+          (title, next) <- breadcrumb this
+          go ((this, title) : back) next

yesod-core/src/Yesod/Core/Class/Handler.hs

@@ -19,7 +19,9 @@ import Control.Monad.Trans.Class (lift)
 import Data.Conduit.Internal (Pipe, ConduitM)
 
 import Control.Monad.Trans.Identity ( IdentityT)
+#if !MIN_VERSION_transformers(0,6,0)
 import Control.Monad.Trans.List     ( ListT    )
+#endif
 import Control.Monad.Trans.Maybe    ( MaybeT   )
 import Control.Monad.Trans.Except   ( ExceptT  )
 import Control.Monad.Trans.Reader   ( ReaderT  )
@@ -76,7 +78,9 @@ instance MonadHandler (WidgetFor site) where
 #define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
 #define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
 GO(IdentityT)
+#if !MIN_VERSION_transformers(0,6,0)
 GO(ListT)
+#endif
 GO(MaybeT)
 GO(ExceptT e)
 GO(ReaderT r)
@@ -104,7 +108,9 @@ liftWidgetT = liftWidget
 #define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget
 #define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget
 GO(IdentityT)
+#if !MIN_VERSION_transformers(0,6,0)
 GO(ListT)
+#endif
 GO(MaybeT)
 GO(ExceptT e)
 GO(ReaderT r)

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

@@ -1,7 +1,9 @@
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Yesod.Core.Class.Yesod where
 
 import           Yesod.Core.Content
@@ -52,8 +54,10 @@ import           Yesod.Core.Types
 import           Yesod.Core.Internal.Session
 import           Yesod.Core.Widget
 import Data.CaseInsensitive (CI)
+import qualified Network.Wai.Handler.Warp as Warp
 import qualified Network.Wai.Request
 import Data.IORef
+import UnliftIO (SomeException, catch, MonadUnliftIO)
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -70,6 +74,16 @@ class RenderRoute site => Yesod site where
     approot :: Approot site
     approot = guessApproot
 
+    -- | @since 1.6.24.0
+    --  allows the user to specify how exceptions are cought.
+    --  by default all async exceptions are thrown and synchronous
+    --  exceptions render a 500 page.
+    -- To catch all exceptions (even async) to render a 500 page, 
+    -- set this to 'UnliftIO.Exception.catchSyncOrAsync'. Beware
+    -- this may have negative effects with functions like 'timeout'.
+    catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a
+    catchHandlerExceptions _ = catch
+
     -- | Output error response pages.
     --
     -- Default value: 'defaultErrorHandler'.
@@ -87,6 +101,8 @@ class RenderRoute site => Yesod site where
             <html>
                 <head>
                     <title>#{pageTitle p}
+                    $maybe description <- pageDescription p
+                      <meta name="description" content="#{description}">
                     ^{pageHead p}
                 <body>
                     $forall (status, msg) <- msgs
@@ -539,8 +555,9 @@ widgetToPageContent w = do
     { wdRef = ref
     , wdHandler = hd
     }
-  GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref
+  GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref
   let title = maybe mempty unTitle mTitle
+      description = unDescription <$> mDescription
       scripts = runUniqueList scripts'
       stylesheets = runUniqueList stylesheets'
 
@@ -610,7 +627,7 @@ widgetToPageContent w = do
             ^{regularScriptLoad}
         |]
 
-    return $ PageContent title headAll $
+    return $ PageContent title description headAll $
         case jsLoader master of
             BottomOfBody -> bodyScript
             _ -> body

yesod-core/src/Yesod/Core/Content.hs

@@ -64,6 +64,7 @@ import qualified Data.Conduit.Internal as CI
 
 import qualified Data.Aeson as J
 import Data.Text.Lazy.Builder (toLazyText)
+import Data.Void (Void, absurd)
 import Yesod.Core.Types
 import Text.Lucius (Css, renderCss)
 import Text.Julius (Javascript, unJavascript)
@@ -103,6 +104,8 @@ instance ToContent Html where
     toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
 instance ToContent () where
     toContent () = toContent B.empty
+instance ToContent Void where
+    toContent = absurd
 instance ToContent (ContentType, Content) where
     toContent = snd
 instance ToContent TypedContent where
@@ -276,6 +279,8 @@ instance ToTypedContent TypedContent where
     toTypedContent = id
 instance ToTypedContent () where
     toTypedContent () = TypedContent typePlain (toContent ())
+instance ToTypedContent Void where
+    toTypedContent = absurd
 instance ToTypedContent (ContentType, Content) where
     toTypedContent (ct, content) = TypedContent ct content
 instance ToTypedContent RepJson where

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

@@ -10,13 +10,24 @@ module Yesod.Core.Dispatch
     , parseRoutesFile
     , parseRoutesFileNoCheck
     , mkYesod
+    , mkYesodOpts
     , mkYesodWith
       -- ** More fine-grained
     , mkYesodData
+    , mkYesodDataOpts
     , mkYesodSubData
+    , mkYesodSubDataOpts
     , mkYesodDispatch
+    , mkYesodDispatchOpts
     , mkYesodSubDispatch
+      -- *** Route generation options
+    , RouteOpts
+    , defaultOpts
+    , setEqDerived
+    , setShowDerived
+    , setReadDerived
       -- *** Helpers
+    , defaultGen
     , getGetMaxExpires
       -- ** Path pieces
     , PathPiece (..)
@@ -46,6 +57,7 @@ import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
 
+import Data.Bits ((.|.), finiteBitSize, shiftL)
 import Data.Text (Text)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as BL
@@ -59,7 +71,7 @@ import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
 import Text.Read (readMaybe)
 import System.Environment (getEnvironment)
-import qualified System.Random as Random
+import System.Entropy (getEntropy)
 import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
 import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
 
@@ -92,8 +104,21 @@ toWaiAppPlain site = do
             , yreGetMaxExpires = getMaxExpires
             }
 
+-- | Generate a random number uniformly distributed in the full range
+-- of 'Int'.
+--
+-- Note: Before 1.6.20, this generates pseudo-random number in an
+-- unspecified range. The range size may not be a power of 2. Since
+-- 1.6.20, this uses a secure entropy source and generates in the full
+-- range of 'Int'.
+--
+-- @since 1.6.21.0
 defaultGen :: IO Int
-defaultGen = Random.getStdRandom Random.next
+defaultGen = bsToInt <$> getEntropy bytes
+  where
+    bits = finiteBitSize (undefined :: Int)
+    bytes = div (bits + 7) 8
+    bsToInt = S.foldl' (\v i -> shiftL v 8 .|. fromIntegral i) 0
 
 -- | Pure low level function to construct WAI application. Usefull
 -- when you need not standard way to run your app, or want to embed it
@@ -172,6 +197,16 @@ toWaiAppLogger logger site = do
 -- middlewares. This set may change at any point without a breaking version
 -- number. Currently, it includes:
 --
+-- * Logging
+--
+-- * GZIP compression
+--
+-- * Automatic HEAD method handling
+--
+-- * Request method override with the _method query string parameter
+--
+-- * Accept header override with the _accept query string parameter
+--
 -- If you need more fine-grained control of middlewares, please use 'toWaiApp'
 -- directly.
 --

yesod-core/src/Yesod/Core/Handler.hs

@@ -245,6 +245,7 @@ import           Text.Blaze.Html               (preEscapedToHtml, toHtml)
 import qualified Data.IORef                    as I
 import           Data.Maybe                    (listToMaybe, mapMaybe)
 import           Data.Typeable                 (Typeable)
+import           Data.Kind                     (Type)
 import           Web.PathPieces                (PathPiece(..))
 import           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
@@ -261,7 +262,7 @@ import qualified Data.Word8 as W8
 import qualified Data.Foldable as Fold
 import           Control.Monad.Logger (MonadLogger, logWarnS)
 
-type HandlerT site (m :: * -> *) = HandlerFor site
+type HandlerT site (m :: Type -> Type) = HandlerFor site
 {-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
 
 get :: MonadHandler m => m GHState
@@ -1226,10 +1227,10 @@ cacheBySet key value = do
 -- Languages are determined based on the following (in descending order
 -- of preference):
 --
--- * The _LANG user session variable.
---
 -- * The _LANG get parameter.
 --
+-- * The _LANG user session variable.
+--
 -- * The _LANG cookie.
 --
 -- * Accept-Language HTTP header.
@@ -1238,11 +1239,12 @@ cacheBySet key value = do
 -- If a matching language is not found the default language will be used.
 --
 -- This is handled by parseWaiRequest (not exposed).
+--
+-- __NOTE__: Before version @1.6.19.0@, this function prioritized the session
+-- variable above all other sources.
+--
 languages :: MonadHandler m => m [Text]
-languages = do
-    mlang <- lookupSession langKey
-    langs <- reqLangs <$> getRequest
-    return $ maybe id (:) mlang langs
+languages = reqLangs <$> getRequest
 
 lookup' :: Eq a => a -> [(a, b)] -> [b]
 lookup' a = map snd . filter (\x -> a == fst x)
@@ -1464,8 +1466,8 @@ respond ct = return . TypedContent ct . toContent
 
 -- | Use a @Source@ for the response body.
 --
--- Note that, for ease of use, the underlying monad is a @HandlerT@. This
--- implies that you can run any @HandlerT@ action. However, since a streaming
+-- Note that, for ease of use, the underlying monad is a @HandlerFor@. This
+-- implies that you can run any @HandlerFor@ action. However, since a streaming
 -- response occurs after the response headers have already been sent, some
 -- actions make no sense here. For example: short-circuit responses, setting
 -- headers, changing status codes, etc.
@@ -1476,8 +1478,8 @@ respondSource :: ContentType
               -> HandlerFor site TypedContent
 respondSource ctype src = HandlerFor $ \hd ->
     -- Note that this implementation relies on the fact that the ResourceT
-    -- environment provided by the server is the same one used in HandlerT.
-    -- This is a safe assumption assuming the HandlerT is run correctly.
+    -- environment provided by the server is the same one used in HandlerFor.
+    -- This is a safe assumption assuming the HandlerFor is run correctly.
     return $ TypedContent ctype $ ContentSource
            $ transPipe (lift . flip unHandlerFor hd) src
 

yesod-core/src/Yesod/Core/Internal/Run.hs

@@ -1,13 +1,28 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternGuards     #-}
-{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TupleSections     #-}
-{-# LANGUAGE FlexibleContexts  #-}
-module Yesod.Core.Internal.Run where
-
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE PatternGuards       #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Yesod.Core.Internal.Run
+  ( toErrorHandler
+  , errFromShow
+  , basicRunHandler
+  , handleError
+  , handleContents
+  , evalFallback
+  , runHandler
+  , safeEh
+  , runFakeHandler
+  , yesodRunner
+  , yesodRender
+  , resolveApproot
+  )
+  where
 
+import qualified Control.Exception as EUnsafe
 import Yesod.Core.Internal.Response
 import           Data.ByteString.Builder      (toLazyByteString)
 import qualified Data.ByteString.Lazy         as BL
@@ -39,6 +54,8 @@ import           Yesod.Core.Internal.Util     (getCurrentMaxExpiresRFC1123)
 import           Yesod.Routes.Class           (Route, renderRoute)
 import           Control.DeepSeq              (($!!), NFData)
 import           UnliftIO.Exception
+import           UnliftIO(MonadUnliftIO, withRunInIO)
+import           Data.Proxy(Proxy(..))
 
 -- | Convert a synchronous exception into an ErrorResponse
 toErrorHandler :: SomeException -> IO ErrorResponse
@@ -71,7 +88,7 @@ basicRunHandler rhe handler yreq resState = do
 
     -- Run the handler itself, capturing any runtime exceptions and
     -- converting them into a @HandlerContents@
-    contents' <- catchAny
+    contents' <- rheCatchHandlerExceptions rhe
         (do
             res <- unHandlerFor handler (hd istate)
             tc <- evaluate (toTypedContent res)
@@ -172,16 +189,19 @@ handleContents handleError' finalSession headers contents =
 -- | Evaluate the given value. If an exception is thrown, use it to
 -- replace the provided contents and then return @mempty@ in place of the
 -- evaluated value.
+--
+-- Note that this also catches async exceptions.
 evalFallback :: (Monoid w, NFData w)
-             => HandlerContents
+             => (forall a. IO a -> (SomeException -> IO a) -> IO a)
+             -> HandlerContents
              -> w
              -> IO (w, HandlerContents)
-evalFallback contents val = catchAny
+evalFallback catcher contents val = catcher
     (fmap (, contents) (evaluate $!! val))
     (fmap ((mempty, ) . HCError) . toErrorHandler)
 
 -- | Function used internally by Yesod in the process of converting a
--- 'HandlerT' into an 'Application'. Should not be needed by users.
+-- 'HandlerFor' into an 'Application'. Should not be needed by users.
 runHandler :: ToTypedContent c
            => RunHandlerEnv site site
            -> HandlerFor site c
@@ -192,8 +212,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
 
     -- Evaluate the unfortunately-lazy session and headers,
     -- propagating exceptions into the contents
-    (finalSession, contents1) <- evalFallback contents0 (ghsSession state)
-    (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
+    (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)
+    (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
     contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
 
     -- Convert the HandlerContents into the final YesodResponse
@@ -216,27 +236,27 @@ safeEh log' er req = do
         (toContent ("Internal Server Error" :: S.ByteString))
         (reqSession req)
 
--- | Run a 'HandlerT' completely outside of Yesod.  This
+-- | Run a 'HandlerFor' completely outside of Yesod.  This
 -- function comes with many caveats and you shouldn't use it
 -- unless you fully understand what it's doing and how it works.
 --
 -- As of now, there's only one reason to use this function at
--- all: in order to run unit tests of functions inside 'HandlerT'
+-- all: in order to run unit tests of functions inside 'HandlerFor'
 -- but that aren't easily testable with a full HTTP request.
 -- Even so, it's better to use @wai-test@ or @yesod-test@ instead
 -- of using this function.
 --
 -- This function will create a fake HTTP request (both @wai@'s
 -- 'Request' and @yesod@'s 'Request') and feed it to the
--- @HandlerT@.  The only useful information the @HandlerT@ may
+-- @HandlerFor@.  The only useful information the @HandlerFor@ may
 -- get from the request is the session map, which you must supply
 -- as argument to @runFakeHandler@.  All other fields contain
 -- fake information, which means that they can be accessed but
 -- won't have any useful information.  The response of the
--- @HandlerT@ is completely ignored, including changes to the
+-- @HandlerFor@ is completely ignored, including changes to the
 -- session, cookies or headers.  We only return you the
--- @HandlerT@'s return value.
-runFakeHandler :: (Yesod site, MonadIO m) =>
+-- @HandlerFor@'s return value.
+runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
                   SessionMap
                -> (site -> Logger)
                -> site
@@ -257,6 +277,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
             , rheLog = messageLoggerSource site $ logger site
             , rheOnError = errHandler
             , rheMaxExpires = maxExpires
+            , rheCatchHandlerExceptions = catchHandlerExceptions site
             }
         handler'
       errHandler err req = do
@@ -298,7 +319,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
   _ <- runResourceT $ yapp fakeRequest
   I.readIORef ret
 
-yesodRunner :: (ToTypedContent res, Yesod site)
+yesodRunner :: forall res site . (ToTypedContent res, Yesod site)
             => HandlerFor site res
             -> YesodRunnerEnv site
             -> Maybe (Route site)
@@ -333,6 +354,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
               , rheLog = log'
               , rheOnError = safeEh log'
               , rheMaxExpires = maxExpires
+              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite
               }
           rhe = rheSafe
               { rheOnError = runHandler rheSafe . errorHandler

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

@@ -1,10 +1,48 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
-module Yesod.Core.Internal.TH where
+{-# LANGUAGE RankNTypes #-}
+module Yesod.Core.Internal.TH
+    ( mkYesod
+    , mkYesodOpts
+
+    , mkYesodWith
+
+    , mkYesodData
+    , mkYesodDataOpts
+
+    , mkYesodSubData
+    , mkYesodSubDataOpts
+
+    , mkYesodWithParser
+    , mkYesodWithParserOpts
+
+    , mkYesodDispatch
+    , mkYesodDispatchOpts
+
+    , masterTypeSyns
+
+    , mkYesodGeneral
+    , mkYesodGeneralOpts
+
+    , mkMDS
+    , mkDispatchInstance
+
+    , mkYesodSubDispatch
+    
+    , subTopDispatch
+    , instanceD
+
+    , RouteOpts
+    , defaultOpts
+    , setEqDerived
+    , setShowDerived
+    , setReadDerived
+    )
+ where
 
 import Prelude hiding (exp)
 import Yesod.Core.Handler
@@ -22,6 +60,7 @@ import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
 
 import Yesod.Routes.TH
 import Yesod.Routes.Parse
+import Yesod.Core.Content (ToTypedContent (..))
 import Yesod.Core.Types
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
@@ -35,7 +74,17 @@ import Yesod.Core.Internal.Run
 mkYesod :: String -- ^ name of the argument datatype
         -> [ResourceTree String]
         -> Q [Dec]
-mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return
+mkYesod = mkYesodOpts defaultOpts
+
+-- | `mkYesod` but with custom options.
+--
+-- @since 1.6.25.0
+mkYesodOpts :: RouteOpts
+            -> String
+            -> [ResourceTree String]
+            -> Q [Dec]
+mkYesodOpts opts name = fmap (uncurry (++)) . mkYesodWithParserOpts opts name False return
+
 
 {-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}
 -- | Similar to 'mkYesod', except contexts and type variables are not parsed. 
@@ -48,15 +97,30 @@ mkYesodWith :: [[String]] -- ^ list of contexts
             -> Q [Dec]
 mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return
 
+
 -- | Sometimes, you will want to declare your routes in one file and define
 -- your handlers elsewhere. For example, this is the only way to break up a
 -- monolithic file into smaller parts. Use this function, paired with
 -- 'mkYesodDispatch', to do just that.
 mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodData name resS = fst <$> mkYesodWithParser name False return resS
+mkYesodData = mkYesodDataOpts defaultOpts
+
+-- | `mkYesodData` but with custom options.
+--
+-- @since 1.6.25.0
+mkYesodDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
+mkYesodDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name False return resS
+
 
 mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS
+mkYesodSubData = mkYesodSubDataOpts defaultOpts
+
+-- |
+--
+-- @since 1.6.25.0
+mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
+mkYesodSubDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name True return resS
+
 
 -- | Parses contexts and type arguments out of name before generating TH.
 mkYesodWithParser :: String                    -- ^ foundation type
@@ -64,11 +128,22 @@ mkYesodWithParser :: String                    -- ^ foundation type
                   -> (Exp -> Q Exp)            -- ^ unwrap handler
                   -> [ResourceTree String]
                   -> Q([Dec],[Dec])
-mkYesodWithParser name isSub f resS = do
+mkYesodWithParser = mkYesodWithParserOpts defaultOpts
+
+-- | Parses contexts and type arguments out of name before generating TH.
+--
+-- @since 1.6.25.0
+mkYesodWithParserOpts :: RouteOpts                 -- ^ Additional route options
+                      -> String                    -- ^ foundation type
+                      -> Bool                      -- ^ is this a subsite
+                      -> (Exp -> Q Exp)            -- ^ unwrap handler
+                      -> [ResourceTree String]
+                      -> Q([Dec],[Dec])
+mkYesodWithParserOpts opts name isSub f resS = do
     let (name', rest, cxt) = case parse parseName "" name of
             Left err -> error $ show err
             Right a -> a
-    mkYesodGeneral cxt name' rest isSub f resS
+    mkYesodGeneralOpts opts cxt name' rest isSub f resS
 
     where
         parseName = do
@@ -100,19 +175,28 @@ mkYesodWithParser name isSub f resS = do
         parseContexts = 
             sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
 
+
 -- | See 'mkYesodData'.
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodDispatch name = fmap snd . mkYesodWithParser name False return
+mkYesodDispatch = mkYesodDispatchOpts defaultOpts
+
+-- | See 'mkYesodDataOpts'
+--
+-- @since 1.6.25.0
+mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
+mkYesodDispatchOpts opts name = fmap snd . mkYesodWithParserOpts opts name False return
+
 
 -- | Get the Handler and Widget type synonyms for the given site.
 masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself?
 masterTypeSyns vs site =
-    [ TySynD (mkName "Handler") (fmap PlainTV vs)
+    [ TySynD (mkName "Handler") (fmap plainTV vs)
       $ ConT ''HandlerFor `AppT` site
-    , TySynD (mkName "Widget")  (fmap PlainTV vs)
+    , TySynD (mkName "Widget")  (fmap plainTV vs)
       $ ConT ''WidgetFor `AppT` site `AppT` ConT ''()
     ]
 
+
 mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
                -> String                    -- ^ foundation type
                -> [String]                  -- ^ arguments for the type
@@ -120,7 +204,20 @@ mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in Ren
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral appCxt' namestr mtys isSub f resS = do
+mkYesodGeneral = mkYesodGeneralOpts defaultOpts
+
+-- |
+--
+-- @since 1.6.25.0
+mkYesodGeneralOpts :: RouteOpts                 -- ^ Options to adjust route creation
+                   -> [[String]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
+                   -> String                    -- ^ foundation type
+                   -> [String]                  -- ^ arguments for the type
+                   -> Bool                      -- ^ is this a subsite
+                   -> (Exp -> Q Exp)            -- ^ unwrap handler
+                   -> [ResourceTree String]
+                   -> Q([Dec],[Dec])
+mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
     let appCxt = fmap (\(c:rest) -> 
             foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
           ) appCxt'
@@ -148,7 +245,7 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
         -- Base type (site type with variables)
     let site = foldl' AppT (ConT name) argtypes
         res = map (fmap (parseType . dropBracket)) resS
-    renderRouteDec <- mkRenderRouteInstance appCxt site res
+    renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res
     routeAttrsDec  <- mkRouteAttrsInstance appCxt site res
     dispatchDec    <- mkDispatchInstance site appCxt f res
     parseRoute <- mkParseRouteInstance appCxt site res
@@ -167,18 +264,11 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
             ]
     return (dataDec, dispatchDec)
 
-mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
-mkMDS f rh = MkDispatchSettings
+
+mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
+mkMDS f rh sd = MkDispatchSettings
     { mdsRunHandler = rh
-    , mdsSubDispatcher =
-        [|\parentRunner getSub toParent env -> yesodSubDispatch
-                                 YesodSubRunnerEnv
-                                    { ysreParentRunner = parentRunner
-                                    , ysreGetSub = getSub
-                                    , ysreToParentRoute = toParent
-                                    , ysreParentEnv = env
-                                    }
-                              |]
+    , mdsSubDispatcher = sd
     , mdsGetPathInfo = [|W.pathInfo|]
     , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
     , mdsMethod = [|W.requestMethod|]
@@ -199,15 +289,35 @@ mkDispatchInstance :: Type                      -- ^ The master site type
                    -> [ResourceTree c]          -- ^ The resource
                    -> DecsQ
 mkDispatchInstance master cxt f res = do
-    clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res
+    clause' <- 
+        mkDispatchClause 
+            (mkMDS 
+                f 
+                [|yesodRunner|] 
+                [|\parentRunner getSub toParent env -> yesodSubDispatch
+                    YesodSubRunnerEnv
+                    { ysreParentRunner = parentRunner
+                    , ysreGetSub = getSub
+                    , ysreToParentRoute = toParent
+                    , ysreParentEnv = env
+                    }
+                |])
+            res
     let thisDispatch = FunD 'yesodDispatch [clause']
     return [instanceD cxt yDispatch [thisDispatch]]
   where
     yDispatch = ConT ''YesodDispatch `AppT` master
 
+
 mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
 mkYesodSubDispatch res = do
-    clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
+    clause' <- 
+        mkDispatchClause
+            (mkMDS 
+                return 
+                [|subHelper|] 
+                [|subTopDispatch|]) 
+        res
     inner <- newName "inner"
     let innerFun = FunD inner [clause']
     helper <- newName "helper"
@@ -219,5 +329,26 @@ mkYesodSubDispatch res = do
                 ]
     return $ LetE [fun] (VarE helper)
 
+
+subTopDispatch :: 
+    (YesodSubDispatch sub master) =>
+        (forall content. ToTypedContent content =>
+            SubHandlerFor child master content ->
+            YesodSubRunnerEnv child master ->
+            Maybe (Route child) ->
+            W.Application
+        ) ->
+        (mid -> sub) ->
+        (Route sub -> Route mid) ->
+        YesodSubRunnerEnv mid master ->
+        W.Application
+subTopDispatch _ getSub toParent env = yesodSubDispatch
+            (YesodSubRunnerEnv
+            { ysreParentRunner = ysreParentRunner env
+            , ysreGetSub = getSub . ysreGetSub env
+            , ysreToParentRoute = ysreToParentRoute env . toParent
+            , ysreParentEnv = ysreParentEnv env
+            })
+
 instanceD :: Cxt -> Type -> [Dec] -> Dec
 instanceD = InstanceD Nothing

yesod-core/src/Yesod/Core/Types.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
 module Yesod.Core.Types where
 
 import Data.Aeson (ToJSON)
@@ -55,7 +56,7 @@ import           Control.Monad.Reader               (MonadReader (..))
 import Control.DeepSeq (NFData (rnf))
 import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
 import Control.Monad.Logger (MonadLoggerIO (..))
-import UnliftIO (MonadUnliftIO (..))
+import UnliftIO (MonadUnliftIO (..), SomeException)
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -182,6 +183,11 @@ data RunHandlerEnv child site = RunHandlerEnv
       --
       -- Since 1.2.0
     , rheMaxExpires :: !Text
+
+      -- | @since 1.6.24.0
+      --   catch function for rendering 500 pages on exceptions.
+      --   by default this is catch from unliftio (rethrows all async exceptions).
+    , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m =>  m a -> (SomeException -> m a) -> m a)
     }
 
 data HandlerData child site = HandlerData
@@ -196,7 +202,13 @@ data YesodRunnerEnv site = YesodRunnerEnv
     , yreSite           :: !site
     , yreSessionBackend :: !(Maybe SessionBackend)
     , yreGen            :: !(IO Int)
-    -- ^ Generate a random number
+    -- ^ Generate a random number uniformly distributed in the full
+    -- range of 'Int'.
+    --
+    -- Note: Before 1.6.20, the default value generates pseudo-random
+    -- number in an unspecified range. The range size may not be a power
+    -- of 2. Since 1.6.20, the default value uses a secure entropy source
+    -- and generates in the full range of 'Int'.
     , yreGetMaxExpires  :: !(IO Text)
     }
 
@@ -231,7 +243,7 @@ data GHState = GHState
 
 -- | An extension of the basic WAI 'W.Application' datatype to provide extra
 -- features needed by Yesod. Users should never need to use this directly, as
--- the 'HandlerT' monad and template haskell code should hide it away.
+-- the 'HandlerFor' monad and template haskell code should hide it away.
 type YesodApp = YesodRequest -> ResourceT IO YesodResponse
 
 -- | A generic widget, allowing specification of both the subsite and master
@@ -283,9 +295,10 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
 --
 -- > PageContent url -> HtmlUrl url
 data PageContent url = PageContent
-    { pageTitle :: !Html
-    , pageHead  :: !(HtmlUrl url)
-    , pageBody  :: !(HtmlUrl url)
+    { pageTitle       :: !Html
+    , pageDescription :: !(Maybe Text)
+    , pageHead        :: !(HtmlUrl url)
+    , pageBody        :: !(HtmlUrl url)
     }
 
 data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
@@ -381,6 +394,7 @@ data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :
 data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }
     deriving (Show, Eq)
 newtype Title = Title { unTitle :: Html }
+newtype Description = Description { unDescription :: Text }
 
 newtype Head url = Head (HtmlUrl url)
     deriving Monoid
@@ -396,6 +410,7 @@ type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder
 data GWData a = GWData
     { gwdBody        :: !(Body a)
     , gwdTitle       :: !(Last Title)
+    , gwdDescription :: !(Last Description)
     , gwdScripts     :: !(UniqueList (Script a))
     , gwdStylesheets :: !(UniqueList (Stylesheet a))
     , gwdCss         :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type
@@ -403,20 +418,21 @@ data GWData a = GWData
     , gwdHead        :: !(Head a)
     }
 instance Monoid (GWData a) where
-    mempty = GWData mempty mempty mempty mempty mempty mempty mempty
+    mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty
 #if !(MIN_VERSION_base(4,11,0))
     mappend = (<>)
 #endif
 instance Semigroup (GWData a) where
-    GWData a1 a2 a3 a4 a5 a6 a7 <>
-      GWData b1 b2 b3 b4 b5 b6 b7 = GWData
+    GWData a1 a2 a3 a4 a5 a6 a7 a8 <>
+      GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData
         (mappend a1 b1)
         (mappend a2 b2)
         (mappend a3 b3)
         (mappend a4 b4)
-        (unionWith mappend a5 b5)
-        (mappend a6 b6)
+        (mappend a5 b5)
+        (unionWith mappend a6 b6)
         (mappend a7 b7)
+        (mappend a8 b8)
 
 data HandlerContents =
       HCContent !H.Status !TypedContent
@@ -473,7 +489,7 @@ instance MonadLogger (WidgetFor site) where
 instance MonadLoggerIO (WidgetFor site) where
     askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
 
--- Instances for HandlerT
+-- Instances for HandlerFor
 instance Applicative (HandlerFor site) where
     pure = HandlerFor . const . return
     (<*>) = ap

yesod-core/src/Yesod/Core/Widget.hs

@@ -33,6 +33,8 @@ module Yesod.Core.Widget
     , setTitleI
     , setDescription
     , setDescriptionI
+    , setDescriptionIdemp
+    , setDescriptionIdempI
     , setOGType
     , setOGImage
       -- ** CSS
@@ -64,6 +66,7 @@ import Yesod.Routes.Class
 import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
 import Text.Shakespeare.I18N (RenderMessage)
 import Data.Text (Text)
+import Data.Kind (Type)
 import qualified Data.Map as Map
 import Language.Haskell.TH.Quote (QuasiQuoter)
 import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
@@ -77,7 +80,7 @@ import qualified Data.Text.Lazy.Builder as TB
 import Yesod.Core.Types
 import Yesod.Core.Class.Handler
 
-type WidgetT site (m :: * -> *) = WidgetFor site
+type WidgetT site (m :: Type -> Type) = WidgetFor site
 {-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
 
 preEscapedLazyText :: TL.Text -> Html
@@ -87,19 +90,19 @@ class ToWidget site a where
     toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
 
 instance render ~ RY site => ToWidget site (render -> Html) where
-    toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
+    toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty mempty
 instance render ~ RY site => ToWidget site (render -> Css) where
     toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
 instance ToWidget site Css where
     toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x
 instance render ~ RY site => ToWidget site (render -> CssBuilder) where
-    toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
 instance ToWidget site CssBuilder where
-    toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
 instance render ~ RY site => ToWidget site (render -> Javascript) where
-    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just x) mempty
 instance ToWidget site Javascript where
-    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty
+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just $ const x) mempty
 instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where
     toWidget = liftWidget
 instance ToWidget site Html where
@@ -130,9 +133,9 @@ instance render ~ RY site => ToWidgetMedia site (render -> Css) where
 instance ToWidgetMedia site Css where
     toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x
 instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
-    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
+    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
 instance ToWidgetMedia site CssBuilder where
-    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
+    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
 
 class ToWidgetBody site a where
     toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
@@ -150,7 +153,7 @@ class ToWidgetHead site a where
     toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
 
 instance render ~ RY site => ToWidgetHead site (render -> Html) where
-    toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
+    toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty mempty . Head
 instance render ~ RY site => ToWidgetHead site (render -> Css) where
     toWidgetHead = toWidget
 instance ToWidgetHead site Css where
@@ -181,7 +184,7 @@ instance ToWidgetHead site Html where
 --    * Google typically shows 55-64 characters, so aim to keep your title
 --      length under 60 characters
 setTitle :: MonadWidget m => Html -> m ()
-setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty
 
 -- | Set the localised page title.
 --
@@ -208,6 +211,14 @@ setDescription :: MonadWidget m => Text -> m ()
 setDescription description =
     toWidgetHead $ [hamlet|<meta name=description content=#{description}>|]
 
+{-# WARNING setDescription
+  [ "setDescription is not idempotent; we recommend setDescriptionIdemp instead"
+  , "Multiple calls to setDescription will insert multiple meta tags in the page head."
+  , "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \
+    \may need to change your layout to include pageDescription."
+  ]
+#-}
+
 -- | Add translated description meta tag to the head of the page
 --
 -- n.b. See comments for @setDescription@.
@@ -220,13 +231,55 @@ setDescriptionI msg = do
     mr <- getMessageRender
     toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|]
 
+{-# WARNING setDescriptionI
+  [ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead"
+  , "Multiple calls to setDescriptionI will insert multiple meta tags in the page head."
+  , "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \
+    \may need to change your layout to include pageDescription."
+  ]
+#-}
+
+-- | Add description meta tag to the head of the page
+--
+-- Google does not use the description tag as a ranking signal, but the
+-- contents of this tag will likely affect your click-through rate since it
+-- shows up in search results.
+--
+-- The average length of the description shown in Google's search results is
+-- about 160 characters on desktop, and about 130 characters on mobile, at time
+-- of writing.
+--
+-- Unlike 'setDescription', this version is *idempotent* - calling it multiple
+-- times will result in only a single description meta tag in the head.
+--
+-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
+--
+-- @since 1.6.23
+setDescriptionIdemp :: MonadWidget m => Text -> m ()
+setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty
+
+-- | Add translated description meta tag to the head of the page
+--
+-- n.b. See comments for @setDescriptionIdemp@.
+--
+-- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple
+-- times will result in only a single description meta tag in the head.
+--
+-- @since 1.6.23
+setDescriptionIdempI
+  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)
+  => msg -> m ()
+setDescriptionIdempI msg = do
+    mr <- getMessageRender
+    setDescriptionIdemp $ mr msg
+
 -- | Add OpenGraph type meta tag to the head of the page
 --
 -- See all available OG types here: https://ogp.me/#types
 --
 -- @since 1.6.18
 setOGType :: MonadWidget m => Text -> m ()
-setOGType a = toWidgetHead $ [hamlet|<meta name="og:type" content=#{a}>|]
+setOGType a = toWidgetHead $ [hamlet|<meta property="og:type" content=#{a}>|]
 
 -- | Add OpenGraph image meta tag to the head of the page
 --
@@ -241,7 +294,7 @@ setOGType a = toWidgetHead $ [hamlet|<meta name="og:type" content=#{a}>|]
 --
 -- @since 1.6.18
 setOGImage :: MonadWidget m => Text -> m ()
-setOGImage a = toWidgetHead $ [hamlet|<meta name="og:image" content=#{a}>|]
+setOGImage a = toWidgetHead $ [hamlet|<meta property="og:image" content=#{a}>|]
 
 -- | Link to the specified local stylesheet.
 addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
@@ -252,7 +305,7 @@ addStylesheetAttrs :: MonadWidget m
                    => Route (HandlerSite m)
                    -> [(Text, Text)]
                    -> m ()
-addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
+addStylesheetAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
 
 -- | Link to the specified remote stylesheet.
 addStylesheetRemote :: MonadWidget m => Text -> m ()
@@ -260,7 +313,7 @@ addStylesheetRemote = flip addStylesheetRemoteAttrs []
 
 -- | Link to the specified remote stylesheet.
 addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
-addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
+addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
 
 addStylesheetEither :: MonadWidget m
                     => Either (Route (HandlerSite m)) Text
@@ -278,7 +331,7 @@ addScript = flip addScriptAttrs []
 
 -- | Link to the specified local script.
 addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()
-addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
+addScriptAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
 
 -- | Link to the specified remote script.
 addScriptRemote :: MonadWidget m => Text -> m ()
@@ -286,7 +339,7 @@ addScriptRemote = flip addScriptRemoteAttrs []
 
 -- | Link to the specified remote script.
 addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
-addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
+addScriptRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
 
 whamlet :: QuasiQuoter
 whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings

yesod-core/src/Yesod/Routes/TH/Dispatch.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}
 module Yesod.Routes.TH.Dispatch
     ( MkDispatchSettings (..)
@@ -73,7 +74,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
     handlePiece (Static str) = return (LitP $ StringL str, Nothing)
     handlePiece (Dynamic _) = do
         x <- newName "dyn"
-        let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])
+        let pat = ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x])
         return (pat, Just $ VarE x)
 
     handlePieces :: [Piece a] -> Q ([Pat], [Exp])
@@ -86,7 +87,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
     mkPathPat final =
         foldr addPat final
       where
-        addPat x y = ConP '(:) [x, y]
+        addPat x y = conPCompat '(:) [x, y]
 
     go :: SDC -> ResourceTree a -> Q Clause
     go sdc (ResourceParent name _check pieces children) = do
@@ -124,11 +125,11 @@ mkDispatchClause MkDispatchSettings {..} resources = do
                 Methods multi methods -> do
                     (finalPat, mfinalE) <-
                         case multi of
-                            Nothing -> return (ConP '[] [], Nothing)
+                            Nothing -> return (conPCompat '[] [], Nothing)
                             Just _ -> do
                                 multiName <- newName "multi"
                                 let pat = ViewP (VarE 'fromPathMultiPiece)
-                                                (ConP 'Just [VarP multiName])
+                                                (conPCompat 'Just [VarP multiName])
                                 return (pat, Just $ VarE multiName)
 
                     let dynsMulti =
@@ -200,3 +201,10 @@ mkDispatchClause MkDispatchSettings {..} resources = do
 defaultGetHandler :: Maybe String -> String -> Q Exp
 defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s
 defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s
+
+conPCompat :: Name -> [Pat] -> Pat
+conPCompat n pats = ConP n
+#if MIN_VERSION_template_haskell(2,18,0)
+                         []
+#endif
+                         pats

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

@@ -1,9 +1,20 @@
-{-# LANGUAGE TemplateHaskell, CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
 module Yesod.Routes.TH.RenderRoute
     ( -- ** RenderRoute
       mkRenderRouteInstance
+    , mkRenderRouteInstanceOpts
     , mkRouteCons
+    , mkRouteConsOpts
     , mkRenderRouteClauses
+
+    , RouteOpts
+    , defaultOpts
+    , setEqDerived
+    , setShowDerived
+    , setReadDerived
     ) where
 
 import Yesod.Routes.TH.Types
@@ -16,16 +27,67 @@ import Data.Text (pack)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Yesod.Routes.Class
 
+-- | General opts data type for generating yesod.
+--
+-- Contains options for what instances are derived for the route. Use the setting
+-- functions on `defaultOpts` to set specific fields.
+--
+-- @since 1.6.25.0
+data RouteOpts = MkRouteOpts
+    { roDerivedEq   :: Bool
+    , roDerivedShow :: Bool
+    , roDerivedRead :: Bool
+    }
+
+-- | Default options for generating routes.
+--
+-- Defaults to all instances derived.
+--
+-- @since 1.6.25.0
+defaultOpts :: RouteOpts
+defaultOpts = MkRouteOpts True True True
+
+-- |
+--
+-- @since 1.6.25.0
+setEqDerived :: Bool -> RouteOpts -> RouteOpts
+setEqDerived b rdo = rdo { roDerivedEq = b }
+
+-- |
+--
+-- @since 1.6.25.0
+setShowDerived :: Bool -> RouteOpts -> RouteOpts
+setShowDerived b rdo = rdo { roDerivedShow = b }
+
+-- |
+--
+-- @since 1.6.25.0
+setReadDerived :: Bool -> RouteOpts -> RouteOpts
+setReadDerived b rdo = rdo { roDerivedRead = b }
+
+-- |
+--
+-- @since 1.6.25.0
+instanceNamesFromOpts :: RouteOpts -> [Name]
+instanceNamesFromOpts (MkRouteOpts eq shw rd) = prependIf eq ''Eq $ prependIf shw ''Show $ prependIf rd ''Read []
+    where prependIf b = if b then (:) else const id
+
 -- | Generate the constructors of a route data type.
 mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])
-mkRouteCons rttypes =
+mkRouteCons = mkRouteConsOpts defaultOpts
+
+-- | Generate the constructors of a route data type, with custom opts.
+--
+-- @since 1.6.25.0
+mkRouteConsOpts :: RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])
+mkRouteConsOpts opts rttypes =
     mconcat <$> mapM mkRouteCon rttypes
   where
     mkRouteCon (ResourceLeaf res) =
         return ([con], [])
       where
         con = NormalC (mkName $ resourceName res)
-            $ map (\x -> (notStrict, x))
+            $ map (notStrict,)
             $ concat [singles, multi, sub]
         singles = concatMap toSingle $ resourcePieces res
         toSingle Static{} = []
@@ -39,16 +101,17 @@ mkRouteCons rttypes =
                 _ -> []
 
     mkRouteCon (ResourceParent name _check pieces children) = do
-        (cons, decs) <- mkRouteCons children
+        (cons, decs) <- mkRouteConsOpts opts children
+        let conts = mapM conT $ instanceNamesFromOpts opts
 #if MIN_VERSION_template_haskell(2,12,0)
-        dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq])
+        dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) conts
 #else
-        dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]
+        dec <- DataD [] (mkName name) [] Nothing cons <$> conts
 #endif
         return ([con], dec : decs)
       where
         con = NormalC (mkName name)
-            $ map (\x -> (notStrict, x))
+            $ map (notStrict,)
             $ singles ++ [ConT $ mkName name]
 
         singles = concatMap toSingle pieces
@@ -67,7 +130,7 @@ mkRenderRouteClauses =
         let cnt = length $ filter isDynamic pieces
         dyns <- replicateM cnt $ newName "dyn"
         child <- newName "child"
-        let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]
+        let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child]
 
         pack' <- [|pack|]
         tsp <- [|toPathPiece|]
@@ -100,7 +163,7 @@ mkRenderRouteClauses =
             case resourceDispatch res of
                 Subsite{} -> return <$> newName "sub"
                 _ -> return []
-        let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
+        let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub
 
         pack' <- [|pack|]
         tsp <- [|toPathPiece|]
@@ -152,9 +215,19 @@ mkRenderRouteClauses =
 -- 'renderRoute' method.  This function uses both 'mkRouteCons' and
 -- 'mkRenderRouteClasses'.
 mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
-mkRenderRouteInstance cxt typ ress = do
+mkRenderRouteInstance = mkRenderRouteInstanceOpts defaultOpts
+
+-- | Generate the 'RenderRoute' instance.
+--
+-- This includes both the 'Route' associated type and the
+-- 'renderRoute' method.  This function uses both 'mkRouteCons' and
+-- 'mkRenderRouteClasses'.
+--
+-- @since 1.6.25.0
+mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
+mkRenderRouteInstanceOpts opts cxt typ ress = do
     cls <- mkRenderRouteClauses ress
-    (cons, decs) <- mkRouteCons ress
+    (cons, decs) <- mkRouteConsOpts opts ress
 #if MIN_VERSION_template_haskell(2,15,0)
     did <- DataInstD [] Nothing (AppT (ConT ''Route) typ) Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
     let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
@@ -175,10 +248,17 @@ mkRenderRouteInstance cxt typ ress = do
           clazzes'
         else
           []
-    clazzes' = [''Show, ''Eq, ''Read]
+    clazzes' = instanceNamesFromOpts opts
 
 notStrict :: Bang
 notStrict = Bang NoSourceUnpackedness NoSourceStrictness
 
 instanceD :: Cxt -> Type -> [Dec] -> Dec
 instanceD = InstanceD Nothing
+
+conPCompat :: Name -> [Pat] -> Pat
+conPCompat n pats = ConP n
+#if MIN_VERSION_template_haskell(2,18,0)
+                         []
+#endif
+                         pats

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Routes.TH.RouteAttrs
@@ -26,7 +27,11 @@ goTree front (ResourceParent name _check pieces trees) =
     toIgnore = length $ filter isDynamic pieces
     isDynamic Dynamic{} = True
     isDynamic Static{} = False
-    front' = front . ConP (mkName name) . ignored
+    front' = front . ConP (mkName name)
+#if MIN_VERSION_template_haskell(2,18,0)
+                          []
+#endif
+                   . ignored
 
 goRes :: (Pat -> Pat) -> Resource a -> Q Clause
 goRes front Resource {..} =

yesod-core/test/YesodCoreTest.hs

@@ -5,13 +5,16 @@ import YesodCoreTest.CleanPath
 import YesodCoreTest.Exceptions
 import YesodCoreTest.Widget
 import YesodCoreTest.Media
+import YesodCoreTest.Meta
 import YesodCoreTest.Links
 import YesodCoreTest.Header
 import YesodCoreTest.NoOverloadedStrings
+import YesodCoreTest.SubSub
 import YesodCoreTest.InternalRequest
 import YesodCoreTest.ErrorHandling
 import YesodCoreTest.Cache
 import YesodCoreTest.ParameterizedSite
+import YesodCoreTest.Breadcrumb
 import qualified YesodCoreTest.WaiSubsite as WaiSubsite
 import qualified YesodCoreTest.Redirect as Redirect
 import qualified YesodCoreTest.JsLoader as JsLoader
@@ -41,6 +44,7 @@ specs = do
       mediaTest
       linksTest
       noOverloadedTest
+      subSubTest
       internalRequestTest
       errorHandlingTest
       cacheTest
@@ -61,3 +65,5 @@ specs = do
       Ssl.sslOnlySpec
       Ssl.sameSiteSpec
       Csrf.csrfSpec
+      breadcrumbTest
+      metaTest

yesod-core/test/YesodCoreTest/Breadcrumb.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module YesodCoreTest.Breadcrumb
+  ( breadcrumbTest,
+  )
+where
+
+import qualified Data.ByteString.Lazy.Char8 as L8
+import Data.Text (Text)
+import Data.Typeable (Typeable)
+import Network.Wai
+import Network.Wai.Test
+import Test.Hspec
+import UnliftIO.IORef
+import Yesod.Core
+
+data A = A
+
+mkYesod
+  "A"
+  [parseRoutes|
+/    RootR GET
+/loop LoopR GET
+|]
+
+instance Yesod A
+
+instance YesodBreadcrumbs A where
+  breadcrumb r = case r of
+    RootR -> pure ("Root", Nothing)
+    LoopR -> pure ("Loop", Just LoopR) -- Purposefully a loop
+
+getRootR :: Handler Text
+getRootR = fst <$> breadcrumbs
+
+getLoopR :: Handler Text
+getLoopR = fst <$> breadcrumbs
+
+breadcrumbTest :: Spec
+breadcrumbTest =
+  describe "Test.Breadcrumb" $ do
+    it "can fetch the root which contains breadcrumbs" $
+      runner $ do
+        res <- request defaultRequest
+        assertStatus 200 res
+    it "gets a 500 for a route with a looping breadcrumb" $
+      runner $ do
+        res <- request defaultRequest {pathInfo = ["loop"]}
+        assertStatus 500 res
+
+runner :: Session () -> IO ()
+runner f = toWaiApp A >>= runSession f

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -1,26 +1,37 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+
 module YesodCoreTest.ErrorHandling
     ( errorHandlingTest
     , Widget
     , resourcesApp
     ) where
+
+import  Data.Typeable(cast)
+import qualified System.Mem as Mem
+import qualified Control.Concurrent.Async as Async
+import Control.Concurrent as Conc
 import Yesod.Core
 import Test.Hspec
 import Network.Wai
 import Network.Wai.Test
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Char8 as S8
-import Control.Exception (SomeException, try)
+import Control.Exception (SomeException, try, AsyncException(..))
+import           UnliftIO.Exception(finally)
 import Network.HTTP.Types (Status, mkStatus)
 import Data.ByteString.Builder (Builder, toLazyByteString)
 import Data.Monoid (mconcat)
 import Data.Text (Text, pack)
 import Control.Monad (forM_)
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom
 import Control.Monad.Trans.State (StateT (..))
 import Control.Monad.Trans.Reader (ReaderT (..))
 import qualified UnliftIO.Exception as E
+import System.Timeout(timeout)
 
 data App = App
 
@@ -45,6 +56,10 @@ mkYesod "App" [parseRoutes|
 /auth-not-adequate AuthNotAdequateR GET
 /args-not-valid ArgsNotValidR POST
 /only-plain-text OnlyPlainTextR GET
+
+/thread-killed ThreadKilledR GET
+/connection-closed-by-peer ConnectionClosedPeerR GET
+/sleep-sec SleepASecR GET
 |]
 
 overrideStatus :: Status
@@ -111,6 +126,23 @@ goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n"
 getGoodBuilderR :: Handler TypedContent
 getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
 
+-- this handler kills it's own thread
+getThreadKilledR :: Handler Html
+getThreadKilledR = do
+  x <- liftIO Conc.myThreadId
+  liftIO $ Async.withAsync (Conc.killThread x) Async.wait
+  pure "unreachablle"
+getSleepASecR :: Handler Html
+getSleepASecR = do
+  liftIO $ Conc.threadDelay 1000000
+  pure "slept a second"
+
+getConnectionClosedPeerR :: Handler Html
+getConnectionClosedPeerR = do
+  x <- liftIO Conc.myThreadId
+  liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait
+  pure "unreachablle"
+
 getErrorR :: Int -> Handler ()
 getErrorR 1 = setSession undefined "foo"
 getErrorR 2 = setSession "foo" undefined
@@ -154,6 +186,10 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "accept CSS, permission denied -> 403" caseCssPermissionDenied
       it "accept image, non-existent path -> 404" caseImageNotFound
       it "accept video, bad method -> 405" caseVideoBadMethod
+      it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows
+      it "custom config rethrows an exception" caseCustomExceptionRethrows
+      it "thread killed rethrow" caseThreadKilledRethrow
+      it "can timeout a runner" canTimeoutARunner
 
 runner :: Session a -> IO a
 runner f = toWaiApp App >>= runSession f
@@ -291,3 +327,50 @@ caseVideoBadMethod = runner $ do
                 ("accept", "video/webm") : requestHeaders defaultRequest
             }
     assertStatus 405 res
+
+fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e
+fromExceptionUnwrap se
+  | Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e
+  | Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e
+  | otherwise = E.fromException se
+
+
+caseThreadKilledRethrow :: IO ()
+caseThreadKilledRethrow =
+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
+                                (Just ThreadKilled) -> True
+                                _ -> False
+  where
+  testcode = runner $ do
+                res <- request defaultRequest { pathInfo = ["thread-killed"] }
+                assertStatus 500 res
+                assertBodyContains "Internal Server Error" res
+
+caseDefaultConnectionCloseRethrows :: IO ()
+caseDefaultConnectionCloseRethrows =
+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
+                                  Just Warp.ConnectionClosedByPeer -> True
+                                  _ -> False
+
+  where
+  testcode = runner $ do
+      _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] }
+      pure ()
+
+caseCustomExceptionRethrows :: IO ()
+caseCustomExceptionRethrows =
+  shouldThrow testcode $ \case Custom.MkMyException -> True
+  where
+    testcode = customAppRunner $ do
+      _res <- request defaultRequest { pathInfo = ["throw-custom-exception"] }
+      pure ()
+    customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f
+
+
+canTimeoutARunner :: IO ()
+canTimeoutARunner = do
+  res <- timeout 1000 $ runner $ do
+    res <- request defaultRequest { pathInfo = ["sleep-sec"] }
+    assertStatus 200 res -- if 500, it's catching the timeout exception
+    pure () -- it should've timeout by now, either being 500 or Nothing
+  res `shouldBe` Nothing -- make sure that pure statement didn't happen.

yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+-- | a custom app that throws an exception
+module YesodCoreTest.ErrorHandling.CustomApp
+    (CustomApp(..)
+    , MyException(..)
+
+    -- * unused
+    , Widget
+    , resourcesCustomApp
+    ) where
+
+
+import Yesod.Core.Types
+import Yesod.Core
+import qualified UnliftIO.Exception as E
+
+data CustomApp = CustomApp
+
+mkYesod "CustomApp" [parseRoutes|
+/throw-custom-exception CustomHomeR GET
+|]
+
+getCustomHomeR :: Handler Html
+getCustomHomeR =
+  E.throwIO MkMyException
+
+data MyException = MkMyException
+ deriving (Show, E.Exception)
+
+instance Yesod CustomApp where
+  -- something we couldn't do before, rethrow custom exceptions
+  catchHandlerExceptions _ action handler =
+    action `E.catch` \exception -> do
+      case E.fromException exception of
+        Just MkMyException -> E.throwIO MkMyException
+        Nothing -> handler exception

yesod-core/test/YesodCoreTest/Meta.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module YesodCoreTest.Meta
+    ( metaTest
+    ) where
+
+import Test.Hspec
+
+import Yesod.Core
+import Network.Wai
+import Network.Wai.Test
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/title TitleR GET
+/desc  DescriptionR GET
+|]
+
+instance Yesod App where
+
+getTitleR :: Handler Html
+getTitleR = defaultLayout $ do
+    setTitle "First title"
+    setTitle "Second title"
+
+getDescriptionR :: Handler Html
+getDescriptionR = defaultLayout $ do
+    setDescriptionIdemp "First description"
+    setDescriptionIdemp "Second description"
+
+metaTest :: Spec
+metaTest = describe "Setting page metadata" $ do
+    describe "Yesod.Core.Widget.setTitle" $ do
+        it "is idempotent" $ runner $ do
+            res <- request defaultRequest
+                        { pathInfo = ["title"]
+                        }
+            assertBody "<!DOCTYPE html>\n<html><head><title>Second title</title></head><body></body></html>" res
+    describe "Yesod.Core.Widget.setDescriptionIdemp" $ do
+        it "is idempotent" $ runner $ do
+            res <- request defaultRequest
+                        { pathInfo = ["desc"]
+                        }
+            assertBody "<!DOCTYPE html>\n<html><head><title></title><meta name=\"description\" content=\"Second description\"></head><body></body></html>" res
+
+runner :: Session () -> IO ()
+runner f = toWaiAppPlain App >>= runSession f

yesod-core/test/YesodCoreTest/SubSub.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module YesodCoreTest.SubSub where
+
+import Test.Hspec
+
+import Yesod.Core
+import Network.Wai.Test
+import qualified Data.Text as T
+import qualified Data.ByteString.Lazy.Char8 as L8
+
+import YesodCoreTest.SubSubData
+
+data App = App { getOuter :: OuterSubSite }
+
+mkYesod "App" [parseRoutes|
+/ OuterSubSiteR OuterSubSite getOuter
+|]
+
+instance Yesod App
+
+getSubR :: SubHandlerFor InnerSubSite master T.Text
+getSubR = return $ T.pack "sub"
+
+instance YesodSubDispatch OuterSubSite master where
+  yesodSubDispatch = $(mkYesodSubDispatch resourcesOuterSubSite)
+
+instance YesodSubDispatch InnerSubSite master where
+  yesodSubDispatch = $(mkYesodSubDispatch resourcesInnerSubSite)
+
+app :: App
+app = App { getOuter = OuterSubSite { getInner = InnerSubSite }}
+
+runner :: Session () -> IO ()
+runner f = toWaiApp app >>= runSession f
+
+case_subSubsite :: IO ()
+case_subSubsite = runner $ do
+  res <- request defaultRequest
+  assertBody (L8.pack "sub") res
+  assertStatus 200 res
+
+subSubTest :: Spec
+subSubTest = describe "YesodCoreTest.SubSub" $ do
+  it "sub_subsite" case_subSubsite

yesod-core/test/YesodCoreTest/SubSubData.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module YesodCoreTest.SubSubData where
+
+import Yesod.Core
+
+
+data OuterSubSite = OuterSubSite { getInner :: InnerSubSite }
+
+data InnerSubSite = InnerSubSite
+
+mkYesodSubData "InnerSubSite" [parseRoutes|
+/ SubR GET
+|]
+
+mkYesodSubData "OuterSubSite" [parseRoutes|
+/ InnerSubSiteR InnerSubSite getInner
+|]

yesod-core/test/YesodCoreTest/Widget.hs

@@ -98,7 +98,7 @@ widgetTest = describe "Test.Widget" $ do
     assertBody "<!DOCTYPE html>\n<html><head><title></title><script>toHead</script><toHead></toHead>\n<style>toWidget{bar:baz}toHead{bar:baz}</style></head><body><script>toBody</script><p>toWidget</p>\n<p>toBody</p>\n<script>toWidget</script></body></html>" res
 
 runner :: Session () -> IO ()
-runner f = toWaiApp Y >>= runSession f
+runner f = toWaiAppPlain Y >>= runSession f
 
 case_addJuliusBody :: IO ()
 case_addJuliusBody = runner $ do

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.18.5
+version:         1.6.25.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -27,6 +27,7 @@ library
 
     build-depends:   base                  >= 4.10     && < 5
                    , aeson                 >= 1.0
+                   , attoparsec-aeson      >= 2.1
                    , auto-update
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.7.1
@@ -39,6 +40,7 @@ library
                    , containers            >= 0.2
                    , cookie                >= 0.4.3    && < 0.5
                    , deepseq               >= 1.3
+                   , entropy
                    , fast-logger           >= 2.2
                    , http-types            >= 0.7
                    , memory
@@ -57,7 +59,7 @@ library
                    , unix-compat
                    , unliftio
                    , unordered-containers  >= 0.2
-                   , vector                >= 0.9      && < 0.13
+                   , vector                >= 0.9      && < 0.14
                    , wai                   >= 3.2
                    , wai-extra             >= 3.0.7
                    , wai-logger            >= 0.2
@@ -145,6 +147,7 @@ test-suite tests
                    YesodCoreTest.Header
                    YesodCoreTest.Csrf
                    YesodCoreTest.ErrorHandling
+                   YesodCoreTest.ErrorHandling.CustomApp
                    YesodCoreTest.Exceptions
                    YesodCoreTest.InternalRequest
                    YesodCoreTest.JsLoader
@@ -154,6 +157,7 @@ test-suite tests
                    YesodCoreTest.LiteApp
                    YesodCoreTest.Media
                    YesodCoreTest.MediaData
+                   YesodCoreTest.Meta
                    YesodCoreTest.NoOverloadedStrings
                    YesodCoreTest.NoOverloadedStringsSub
                    YesodCoreTest.ParameterizedSite
@@ -170,6 +174,8 @@ test-suite tests
                    YesodCoreTest.StubSslOnly
                    YesodCoreTest.StubStrictSameSite
                    YesodCoreTest.StubUnsecured
+                   YesodCoreTest.SubSub
+                   YesodCoreTest.SubSubData
                    YesodCoreTest.WaiSubsite
                    YesodCoreTest.Widget
                    YesodCoreTest.YesodTest

yesod-eventsource/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.6.0.1
+
+* Update documentation from `HandlerT` to `HandlerFor` [#1703](https://github.com/yesodweb/yesod/pull/1703)
+
 ## 1.6.0
 
 * Upgrade to yesod-core 1.6.0

yesod-eventsource/Yesod/EventSource.hs

@@ -63,9 +63,9 @@ sourceToSource src =
             Just x -> yield (Chunk x) >> yield Flush
 
 
--- | Return a Server-Sent Event stream given a 'HandlerT' action
+-- | Return a Server-Sent Event stream given a 'HandlerFor' action
 -- that is repeatedly called.  A state is threaded for the action
--- so that it may avoid using @IORefs@.  The @HandlerT@ action
+-- so that it may avoid using @IORefs@.  The @HandlerFor@ action
 -- may sleep or block while waiting for more data.  The HTTP
 -- socket is flushed after every list of simultaneous events.
 -- The connection is closed as soon as an 'ES.CloseEvent' is

yesod-eventsource/yesod-eventsource.cabal

@@ -1,5 +1,6 @@
+cabal-version:   >= 1.10
 name:            yesod-eventsource
-version:         1.6.0
+version:         1.6.0.1
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa <felipe.lessa@gmail.com>
@@ -7,13 +8,13 @@ maintainer:      Felipe Lessa <felipe.lessa@gmail.com>
 synopsis:        Server-sent events support for Yesod apps.
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.6
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-eventsource>
 extra-source-files: README.md ChangeLog.md
 
 library
+    default-language: Haskell2010
     build-depends:   base                  >= 4.10     && < 5
                    , blaze-builder
                    , conduit               >= 1.3

yesod-form-multi/ChangeLog.md

@@ -1,5 +1,30 @@
 # Changelog
 
+## 1.7.0.2
+
+* Allow yesod-form 1.7
+
+## 1.7.0.1
+
+[#1716](https://github.com/yesodweb/yesod/pull/1716)
+
+* Fixed bug where duplicating `<option>` tags caused the `value` field to be cleared
+
+## 1.7.0
+
+[#1707](https://github.com/yesodweb/yesod/pull/1707)
+
+* Added delete buttons
+* Added support for custom text or icons inside add/delete buttons
+* Added new presets for Bootstrap + Font Awesome icons
+* Added support for more complex fields that have multiple parts stuch as radio fields
+* Improved support for fields that rely on hidden inputs like WYSIWYG editors
+* Fixed redundant class in existing Bootstrap presets
+* Fixed styling not applying to error messages on individual fields
+* Tooltips now show once at the top of the multi-field group when using `amulti`
+
 ## 1.6.0
 
-* Added `Yesod.Form.MultiInput` which supports multi-input forms without needing to submit the form to add an input field [#1601](https://github.com/yesodweb/yesod/pull/1601)
+[#1601](https://github.com/yesodweb/yesod/pull/1601)
+
+* Added `Yesod.Form.MultiInput` which supports multi-input forms without needing to submit the form to add an input field

yesod-form-multi/README.md

@@ -1,7 +1,5 @@
 ## yesod-form-multi
 
 Support for creating forms in which the user can specify how many inputs to submit. Includes support for enforcing a minimum number of values.
-Intended as an alternative to `Yesod.Form.MassInput`.
 
-# Limitations
-- If the user adds too many fields then there is currently no support for a "delete button" although fields submitted empty are considered to be deleted.
+Intended as an alternative to `Yesod.Form.MassInput`.

yesod-form-multi/Yesod/Form/MultiInput.hs

@@ -17,16 +17,19 @@ module Yesod.Form.MultiInput
     , mmulti
     , amulti
     , bs3Settings
+    , bs3FASettings
     , bs4Settings
+    , bs4FASettings
     ) where
 
 import Control.Arrow (second)
 import Control.Monad (liftM)
 import Control.Monad.Trans.RWS (ask, tell)
 import qualified Data.Map as Map
-import Data.Maybe (fromJust, listToMaybe, fromMaybe)
+import Data.Maybe (fromJust, listToMaybe, fromMaybe, isJust)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Text.Julius (rawJS)
 import Yesod.Core
 import Yesod.Form.Fields (intField)
 import Yesod.Form.Functions
@@ -41,43 +44,132 @@ instance ToJavascript Text where toJavascript = toJavascript . toJSON
 #endif
 #endif
 
--- @since 1.6.0
+-- | By default delete buttons have a @margin-left@ property of @0.75rem@.
+-- You can override this by specifying an alternative value in a class
+-- which is then passed inside 'MultiSettings'.
+--
+-- @since 1.7.0
 data MultiSettings site = MultiSettings
-    { msAddClass :: Text -- ^ Class to be applied to the "add another" button.
+    { msAddClass :: !Text -- ^ Class to be applied to the "add another" button.
+    , msDelClass :: !Text -- ^ Class to be applied to the "delete" button.
+    , msTooltipClass :: Text -- ^ Only used in applicative forms. Class to be applied to the tooltip.
+    , msWrapperErrClass :: !Text -- ^ Class to be applied to the wrapper if it's field has an error.
+    , msAddInner :: !(Maybe Html) -- ^ Inner Html of add button, defaults to "Add Another". Useful for adding icons inside buttons.
+    , msDelInner :: !(Maybe Html) -- ^ Inner Html of delete button, defaults to "Delete". Useful for adding icons inside buttons.
     , msErrWidget :: Maybe (Html -> WidgetFor site ()) -- ^ Only used in applicative forms. Create a widget for displaying errors.
     }
 
--- @since 1.6.0
+-- | The general structure of each individually generated field is as follows.
+-- There is an external wrapper element containing both an inner wrapper and any
+-- error messages that apply to that specific field. The inner wrapper contains
+-- both the field and it's corresponding delete button.
+--
+-- The structure is illustrated by the following:
+-- 
+-- > <div .#{wrapperClass}>
+-- >     <div .#{wrapperClass}-inner>
+-- >         ^{fieldWidget}
+-- >         ^{deleteButton}
+-- >     ^{maybeErrorMessages}
+--
+-- Each wrapper element has the same class which is automatically generated. This class
+-- is returned in the 'MultiView' should you wish to change the styling. The inner wrapper
+-- uses the same class followed by @-inner@. By default the wrapper and inner wrapper has
+-- classes are as follows:
+-- 
+-- > .#{wrapperClass} {
+-- >     margin-bottom: 1rem;
+-- > }
+-- >
+-- > .#{wrapperClass}-inner {
+-- >     display: flex;
+-- >     flex-direction: row;
+-- > }
+--
+-- @since 1.7.0
 data MultiView site = MultiView
     { mvCounter :: FieldView site -- ^ Hidden counter field.
     , mvFields :: [FieldView site] -- ^ Input fields.
     , mvAddBtn :: FieldView site -- ^ Button to add another field.
+    , mvWrapperClass :: Text -- ^ Class applied to a div wrapping each field with it's delete button.
     }
 
 -- | 'MultiSettings' for Bootstrap 3.
 --
 -- @since 1.6.0
 bs3Settings :: MultiSettings site
-bs3Settings = MultiSettings "btn btn-default" (Just errW)
+bs3Settings = MultiSettings
+    "btn btn-default"
+    "btn btn-danger"
+    "help-block"
+    "has-error"
+    Nothing Nothing (Just errW)
     where
         errW err = 
             [whamlet|
-                <span .help-block .error-block>#{err}
+                <span .help-block>#{err}
             |]
 
 -- | 'MultiSettings' for Bootstrap 4.
 --
 -- @since 1.6.0
 bs4Settings :: MultiSettings site
-bs4Settings = MultiSettings "btn btn-basic" (Just errW)
+bs4Settings = MultiSettings
+    "btn btn-secondary"
+    "btn btn-danger"
+    "form-text text-muted"
+    "has-error"
+    Nothing Nothing (Just errW)
     where
         errW err =
             [whamlet|
                 <div .invalid-feedback>#{err}
             |]
 
+-- | 'MultiSettings' for Bootstrap 3 with Font Awesome 5 Icons.
+-- Uses @fa-plus@ for the add button and @fa-trash-alt@ for the delete button.
+--
+-- @since 1.7.0
+bs3FASettings :: MultiSettings site
+bs3FASettings = MultiSettings
+    "btn btn-default"
+    "btn btn-danger"
+    "help-block"
+    "has-error"
+    addIcon delIcon (Just errW)
+    where
+        addIcon = Just [shamlet|<i class="fas fa-plus">|]
+        delIcon = Just [shamlet|<i class="fas fa-trash-alt">|]
+        errW err = 
+            [whamlet|
+                <span .help-block>#{err}
+            |]
+
+-- | 'MultiSettings' for Bootstrap 4 with Font Awesome 5 Icons.
+-- Uses @fa-plus@ for the add button and @fa-trash-alt@ for the delete button.
+--
+-- @since 1.7.0
+bs4FASettings :: MultiSettings site
+bs4FASettings = MultiSettings
+    "btn btn-secondary"
+    "btn btn-danger"
+    "form-text text-muted"
+    "has-error"
+    addIcon delIcon (Just errW)
+    where
+        addIcon = Just [shamlet|<i class="fas fa-plus">|]
+        delIcon = Just [shamlet|<i class="fas fa-trash-alt">|]
+        errW err =
+            [whamlet|
+                <div .invalid-feedback>#{err}
+            |]
+
 -- | Applicative equivalent of 'mmulti'.
 --
+-- Note about tooltips:
+-- Rather than displaying the tooltip alongside each field the
+-- tooltip is displayed once at the top of the multi-field set.
+--
 -- @since 1.6.0
 amulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
     => Field m a
@@ -92,20 +184,19 @@ amulti field fs defs minVals ms = formToAForm $
         mform = do
             (fr, MultiView {..}) <- mmulti field fs defs minVals ms
 
-            let widget = do
+            let (fv : _) = mvFields
+                widget = do
                     [whamlet|
+                        $maybe tooltip <- fvTooltip fv
+                            <small .#{msTooltipClass ms}>#{tooltip}
+
                         ^{fvInput mvCounter}
 
                         $forall fv <- mvFields
                             ^{fvInput fv}
 
-                            $maybe err <- fvErrors fv
-                                $maybe errW <- msErrWidget ms
-                                    ^{errW err}
-
                         ^{fvInput mvAddBtn}
                     |]
-                (fv : _) = mvFields
                 view = FieldView
                     { fvLabel = fvLabel fv
                     , fvTooltip = Nothing
@@ -130,11 +221,10 @@ mmulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
     -> Int
     -> MultiSettings site
     -> MForm m (FormResult [a], MultiView site)
-mmulti field fs@FieldSettings {..} defs minVals ms = do
-    fieldClass <- newFormIdent
-    let fs' = fs {fsAttrs = addClass fieldClass fsAttrs}
-        minVals' = if minVals < 0 then 0 else minVals
-    mhelperMulti field fs' fieldClass defs minVals' ms
+mmulti field fs defs minVals' ms = do
+    wrapperClass <- lift newIdent
+    let minVals = if minVals' < 0 then 0 else minVals'
+    mhelperMulti field fs wrapperClass defs minVals ms
 
 -- Helper function, does most of the work for mmulti.
 mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
@@ -145,21 +235,22 @@ mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMe
     -> Int
     -> MultiSettings site
     -> MForm m (FormResult [a], MultiView site)
-mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals MultiSettings {..} = do
+mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals MultiSettings {..} = do
     mp <- askParams
     (_, site, langs) <- ask
     name <- maybe newFormIdent return fsName
-    theId <- maybe newFormIdent return fsId
+    theId <- lift $ maybe newIdent return fsId
     cName <- newFormIdent
-    cid <- newFormIdent
-    addBtnId <- newFormIdent 
+    cid <- lift newIdent
+    addBtnId <- lift newIdent
+    delBtnPrefix <- lift newIdent
 
     let mr2 = renderMessage site langs
         cDef = length defs
         cfs = FieldSettings "" Nothing (Just cid) (Just cName) [("hidden", "true")]
         mkName i = name `T.append` (T.pack $ '-' : show i)
         mkId i = theId `T.append` (T.pack $ '-' : show i)
-        mkNames c = [(mkName i, mkId i) | i <- [0 .. c]]
+        mkNames c = [(i, (mkName i, mkId i)) | i <- [0 .. c]]
         onMissingSucc _ _ = FormSuccess Nothing
         onMissingFail m l = FormFailure [renderMessage m l MsgValueRequired]
         isSuccNothing r = case r of
@@ -174,7 +265,7 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals Mult
         Just p -> mkRes intField cfs p mfs cName onMissingFail FormSuccess
 
     -- generate counter view
-    cView <- mkView intField cfs cr cid cName True
+    cView <- mkView intField cfs cr Nothing Nothing msWrapperErrClass cid cName True
 
     let counter = case cRes of
             FormSuccess c -> c
@@ -186,17 +277,74 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals Mult
             if cDef == 0
                 then [(FormMissing, Left "")]
                 else [(FormMissing, Right d) | d <- defs]
-        Just p -> mapM (\n -> mkRes field fs p mfs n onMissingSucc (FormSuccess . Just)) (map fst $ mkNames counter)
+        Just p -> mapM
+            (\n -> mkRes field fs p mfs n onMissingSucc (FormSuccess . Just))
+            (map (fst . snd) $ mkNames counter)
+
+    -- delete button
+
+    -- The delFunction is included down with the add button rather than with
+    -- each delete button to ensure that the function only gets included once.
+    let delFunction = toWidget
+            [julius|
+                function deleteField_#{rawJS theId}(wrapper) {
+                    var numFields = $('.#{rawJS wrapperClass}').length;
+
+                    if (numFields == 1)
+                    {
+                        wrapper.find("*").each(function() {
+                            removeVals($(this));
+                        });
+                    }
+                    else
+                        wrapper.remove();
+                }
+
+                function removeVals(e) {
+                    // input types where we don't want to reset the value
+                    const keepValueTypes = ["radio", "checkbox", "button"];
+
+                    var shouldKeep = keepValueTypes.includes(e.prop('type'))
+                                        || e.prop("tagName") == "OPTION";
+
+                    // uncheck any checkboxes or radio fields and empty any text boxes
+                    if(e.prop('checked') == true)
+                        e.prop('checked', false);
+
+                    if(!shouldKeep)
+                        e.val("").trigger("change");
+                        // trigger change is to ensure WYSIWYG editors are updated
+                        // when their hidden code field is cleared
+                }
+            |]
+
+        mkDelBtn fieldId = do
+            let delBtnId = delBtnPrefix `T.append` fieldId
+            [whamlet|
+                <button ##{delBtnId} .#{msDelClass} style="margin-left: 0.75rem" type="button">
+                    $maybe inner <- msDelInner
+                        #{inner}
+                    $nothing
+                        Delete
+            |]
+            toWidget
+                [julius|
+                    $('##{rawJS delBtnId}').click(function() {
+                        var field = $('##{rawJS fieldId}');
+                        deleteField_#{rawJS theId}(field.parents('.#{rawJS wrapperClass}'));
+                    });                    
+                |]
 
     -- generate field views
     (rs, fvs) <- do
-        let mkView' ((n,i), r@(res, _)) = do
-                fv <- mkView field fs r i n False
+        let mkView' ((c, (n,i)), r@(res, _)) = do
+                let del = Just (mkDelBtn i, wrapperClass, c)
+                fv <- mkView field fs r del msErrWidget msWrapperErrClass i n True
                 return (res, fv)
             xs = zip (mkNames counter) results
             notSuccNothing (_, (r,_)) = not $ isSuccNothing r
             ys = case filter notSuccNothing xs of
-                [] -> [((mkName 0, mkId 0), (FormSuccess Nothing, Left ""))] -- always need at least one value to generate a field
+                [] -> [((0, (mkName 0, mkId 0)), (FormSuccess Nothing, Left ""))] -- always need at least one value to generate a field
                 zs -> zs
         rvs <- mapM mkView' ys
         return $ unzip rvs
@@ -214,23 +362,77 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals Mult
                 fRes -> (fRes, False)
     
         -- create add button
+        -- also includes some styling / functions that we only want to include once
         btnWidget = do
             [whamlet|
-                <button ##{addBtnId} .#{msAddClass} type="button">Add Another
+                <button ##{addBtnId} .#{msAddClass} type="button">
+                    $maybe inner <- msAddInner
+                        #{inner}
+                    $nothing
+                        Add Another
             |]
+            toWidget
+                [lucius|
+                    .#{wrapperClass} {
+                        margin-bottom: 1rem;
+                    }
+                    .#{wrapperClass}-inner {
+                        display: flex;
+                        flex-direction: row;
+                    }
+                |]
+            delFunction -- function used by delete buttons, included here so that it only gets included once
             toWidget
                 [julius|
-                    var extraFields = 0;
-                    $("#" + #{addBtnId}).click(function() {
-                        extraFields++;
-                        var newNumber = parseInt(#{show counter}) + extraFields;
+                    var extraFields_#{rawJS theId} = 0;
+                    $('##{rawJS addBtnId}').click(function() {
+                        extraFields_#{rawJS theId}++;
+                        var newNumber = parseInt(#{show counter}) + extraFields_#{rawJS theId};
                         $("#" + #{cid}).val(newNumber);
                         var newName = #{name} + "-" + newNumber;
                         var newId = #{theId} + "-" + newNumber;
+                        var newDelId = #{delBtnPrefix} + newId;
                         
-                        var newElem = $("." + #{fieldClass}).first().clone();
-                        newElem.val("").attr('name', newName).attr('id', newId);
-                        newElem.insertBefore("#" + #{addBtnId})
+                        // get new wrapper and remove old error messages
+                        var newWrapper = $('.#{rawJS wrapperClass}').first().clone();
+                        newWrapper.children( ':not(.#{rawJS wrapperClass}-inner)' ).remove();
+                        newWrapper.removeClass(#{msWrapperErrClass});
+
+                        // get counter from wrapper
+                        var oldCount = newWrapper.data("counter");
+                        var oldName = #{name} + "-" + oldCount;
+                        var oldId = #{theId} + "-" + oldCount;
+                        var oldDelBtn = #{delBtnPrefix} + oldId;
+
+                        // replace any id, name or for attributes that began with
+                        // the old values and replace them with the new values
+                        var idRegex = new RegExp("^" + oldId);
+                        var nameRegex = new RegExp("^" + oldName);
+
+                        var els = newWrapper.find("*");
+                        els.each(function() {
+                            var e = $(this);
+
+                            if(e.prop('id') != undefined)
+                                e.prop('id', e.prop('id').replace(idRegex, newId));
+
+                            if(e.prop('name') != undefined)
+                                e.prop('name', e.prop('name').replace(nameRegex, newName));
+
+                            if(e.prop('for') != undefined)
+                                e.prop('for', e.prop('for').replace(idRegex, newId)); // radio fields use id in for attribute
+
+                            removeVals(e);
+                        });
+
+                        // set new counter on wrapper
+                        newWrapper.attr("data-counter", newNumber);
+
+                        var newDelBtn = newWrapper.find('[id^=#{rawJS delBtnPrefix}]');
+                        newDelBtn.prop('id', newDelId);
+                        newDelBtn.click(() => deleteField_#{rawJS theId}(newWrapper));
+
+                        newWrapper.insertBefore('##{rawJS addBtnId}');
                     });
                 |]
 
@@ -243,7 +445,7 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals Mult
             , fvRequired = False
             }
 
-    return (res, MultiView cView fvs btnView)
+    return (res, MultiView cView fvs btnView wrapperClass)
 
 -- Search for the given field's name in the environment,
 -- parse any values found and construct a FormResult.
@@ -274,21 +476,42 @@ mkView :: (site ~ HandlerSite m, MonadHandler m)
     => Field m a
     -> FieldSettings site
     -> (FormResult b, Either Text a)
+    -- Delete button widget, class for div wrapping each field with it's delete button and counter value for that field.
+    -- Nothing if the field passed doesn't need a delete button e.g. if it is the counter field.
+    -> Maybe (WidgetFor site (), Text, Int)
+    -> Maybe (Html -> WidgetFor site ()) -- Function to display error messages.
+    -> Text
     -> Text
     -> Text
     -> Bool
     -> MForm m (FieldView site)
-mkView Field {..} FieldSettings {..} (res, val) theId name isReq = do
+mkView Field {..} FieldSettings {..} (res, val) mdel merrW errClass theId name isReq = do
     (_, site, langs) <- ask
     let mr2 = renderMessage site langs
+        merr = case res of
+                FormFailure [e] -> Just $ toHtml e
+                _ -> Nothing
+        fv' = fieldView theId name fsAttrs val isReq
+        fv = do
+            [whamlet|
+                $maybe (delBtn, wrapperClass, counter) <- mdel
+                    <div .#{wrapperClass} :isJust merr:.#{errClass} data-counter=#{counter}>
+                        <div .#{wrapperClass}-inner>
+                            ^{fv'}
+                            ^{delBtn}
+                            
+                        $maybe err <- merr
+                            $maybe errW <- merrW
+                                ^{errW err}
+                        
+                $nothing
+                    ^{fv'}
+            |]
     return $ FieldView
         { fvLabel = toHtml $ mr2 fsLabel
         , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
         , fvId = theId
-        , fvInput = fieldView theId name fsAttrs val isReq
-        , fvErrors =
-            case res of
-                FormFailure [e] -> Just $ toHtml e
-                _ -> Nothing
+        , fvInput = fv
+        , fvErrors = merr
         , fvRequired = isReq
         }

yesod-form-multi/yesod-form-multi.cabal

@@ -1,5 +1,5 @@
 name:            yesod-form-multi
-version:         1.6.0
+version:         1.7.0.2
 license:         MIT
 license-file:    LICENSE
 author:          James Burton <jamesejburton@gmail.com>
@@ -7,7 +7,7 @@ maintainer:      James Burton <jamesejburton@gmail.com>
 synopsis:        Multi-input form handling for Yesod Web Framework
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.8
+cabal-version:   >= 1.10
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-form-multi>.
@@ -19,13 +19,14 @@ flag network-uri
   default: True
 
 library
+    default-language: Haskell2010
     build-depends:   base                  >= 4.10     && < 5
                    , containers            >= 0.2
                    , shakespeare           >= 2.0
                    , text                  >= 0.9
                    , transformers          >= 0.2.2
                    , yesod-core            >= 1.6      && < 1.7
-                   , yesod-form            >= 1.6      && < 1.7
+                   , yesod-form            >= 1.6      && < 1.8
 
     if flag(network-uri)
       build-depends: network-uri >= 2.6

yesod-form/ChangeLog.md

@@ -1,5 +1,33 @@
 # ChangeLog for yesod-form
 
+## 1.7.6
+
+* Added `datetimeLocalField` for creating a html `<input type="datetime-local">` [#1817](https://github.com/yesodweb/yesod/pull/1817)
+
+## 1.7.5
+
+* Add Romanian translation [#1801](https://github.com/yesodweb/yesod/pull/1801)
+
+## 1.7.4
+
+* Added a `Monad AForm` instance only when `transformers` >= 0.6 [#1795](https://github.com/yesodweb/yesod/pull/1795)
+
+## 1.7.3
+
+* Fixed `radioField` according to Bootstrap 3 docs. [#1783](https://github.com/yesodweb/yesod/pull/1783)
+
+## 1.7.2
+
+* Added `withRadioField` and re-express `radioField` into that. [#1775](https://github.com/yesodweb/yesod/pull/1775)
+
+## 1.7.1
+
+* Added `colorField` for creating a html color field (`<input type="color">`) [#1748](https://github.com/yesodweb/yesod/pull/1748)
+
+## 1.7.0
+
+* Extended `OptionList` by `OptionListGrouped` and implemented grouped select fields (`<select>` with `<optgroup>`) [#1722](https://github.com/yesodweb/yesod/pull/1722)
+
 ## 1.6.7
 
 * Added equivalent version of `mreqMsg` for `areq` and `wreq` correspondingly [#1628](https://github.com/yesodweb/yesod/pull/1628)

yesod-form/README.md

@@ -3,7 +3,7 @@
 Form handling for Yesod, in the same style as formlets. See [the forms
 chapter](http://www.yesodweb.com/book/forms) of the Yesod book.
 
-This package provies a set of basic form inputs such as text, number, time,
+This package provides a set of basic form inputs such as text, number, time,
 checkbox, select, textarea, and etc. via `Yesod.Form.Fields` module.  Also,
 there is `Yesod.Form.Nic` module providing richtext field using Nic editor.
 However, this module is grandfathered now and Nic editor is not actively

yesod-form/Yesod/Form/Fields.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE CPP #-}
 -- | Field functions allow you to easily create and validate forms, cleanly handling the uncertainty of parsing user input.
@@ -45,8 +46,10 @@ module Yesod.Form.Fields
     , selectFieldHelper
     , selectField
     , selectFieldList
+    , selectFieldListGrouped
     , radioField
     , radioFieldList
+    , withRadioField
     , checkboxesField
     , checkboxesFieldList
     , multiSelectField
@@ -54,10 +57,14 @@ module Yesod.Form.Fields
     , Option (..)
     , OptionList (..)
     , mkOptionList
+    , mkOptionListGrouped
     , optionsPersist
     , optionsPersistKey
     , optionsPairs
+    , optionsPairsGrouped
     , optionsEnum
+    , colorField
+    , datetimeLocalField
     ) where
 
 import Yesod.Form.Types
@@ -68,7 +75,7 @@ import Text.Blaze (ToMarkup (toMarkup), unsafeByteString)
 #define ToHtml ToMarkup
 #define toHtml toMarkup
 #define preEscapedText preEscapedToMarkup
-import Data.Time (Day, TimeOfDay(..))
+import Data.Time (Day, TimeOfDay(..), LocalTime (LocalTime))
 import qualified Text.Email.Validate as Email
 import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
@@ -80,7 +87,7 @@ import Database.Persist (Entity (..), SqlType (SqlString), PersistRecordBackend,
 import Database.Persist (Entity (..), SqlType (SqlString), PersistEntity, PersistQuery, PersistEntityBackend)
 #endif
 import Text.HTML.SanitizeXSS (sanitizeBalance)
-import Control.Monad (when, unless)
+import Control.Monad (when, unless, forM_)
 import Data.Either (partitionEithers)
 import Data.Maybe (listToMaybe, fromMaybe)
 
@@ -92,7 +99,8 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
 import Data.Text as T ( Text, append, concat, cons, head
-                      , intercalate, isPrefixOf, null, unpack, pack, splitOn
+                      , intercalate, isPrefixOf, null, unpack, pack
+                      , split, splitOn
                       )
 import qualified Data.Text as T (drop, dropWhile)
 import qualified Data.Text.Read
@@ -113,6 +121,8 @@ import Data.String (IsString)
 import Data.Monoid
 #endif
 
+import Data.Char (isHexDigit)
+
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
 
@@ -169,20 +179,20 @@ timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Tim
 timeField = timeFieldTypeTime
 
 -- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'.
--- 
+--
 -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
 --
--- Since 1.4.2
-timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay  
+-- @since 1.4.2
+timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
 timeFieldTypeTime = timeFieldOfType "time"
 
 -- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system).
 --
 -- This function exists for backwards compatibility with the old implementation of 'timeField', which used to use @type="text"@. Consider using 'timeField' or 'timeFieldTypeTime' for improved UX and validation from the browser.
--- 
+--
 -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
 --
--- Since 1.4.2
+-- @since 1.4.2
 timeFieldTypeText :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
 timeFieldTypeText = timeFieldOfType "text"
 
@@ -215,7 +225,7 @@ $newline never
   where showVal = either id (pack . renderHtml)
 
 -- | A newtype wrapper around a 'Text' whose 'ToMarkup' instance converts newlines to HTML @\<br>@ tags.
--- 
+--
 -- (When text is entered into a @\<textarea>@, newline characters are used to separate lines.
 -- If this text is then placed verbatim into HTML, the lines won't be separated, thus the need for replacing with @\<br>@ tags).
 -- If you don't need this functionality, simply use 'unTextarea' to access the raw text.
@@ -344,7 +354,7 @@ timeParser = do
         if i < 0 || i >= 60
             then fail $ show $ msg $ pack xy
             else return $ fromIntegral (i :: Int)
-            
+
 -- | Creates an input with @type="email"@. Yesod will validate the email's correctness according to RFC5322 and canonicalize it by removing comments and whitespace (see "Text.Email.Validate").
 emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
 emailField = Field
@@ -362,7 +372,7 @@ $newline never
 
 -- | Creates an input with @type="email"@ with the <http://w3c.github.io/html/sec-forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'.
 --
--- Since 1.3.7
+-- @since 1.3.7
 multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
 multiEmailField = Field
     { fieldParse = parseHelper $
@@ -427,7 +437,15 @@ selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg
                 -> Field (HandlerFor site) a
 selectFieldList = selectField . optionsPairs
 
--- | Creates a @\<select>@ tag for selecting one option. Example usage:
+-- | Creates a @\<select>@ tag with @\<optgroup>@s for selecting one option.
+--
+-- @since 1.7.0
+selectFieldListGrouped :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
+                => [(msg, [(msg, a)])]
+                -> Field (HandlerFor site) a
+selectFieldListGrouped = selectField . optionsPairsGrouped
+
+-- | Creates a @\<select>@ tag with optional @\<optgroup>@s for selecting one option. Example usage:
 --
 -- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing
 selectField :: (Eq a, RenderMessage site FormMessage)
@@ -446,6 +464,9 @@ $newline never
 $newline never
 <option value=#{value} :isSel:selected>#{text}
 |]) -- inside
+    (Just $ \label -> [whamlet|
+<optgroup label=#{label}>
+|]) -- group label
 
 -- | Creates a @\<select>@ tag for selecting multiple options.
 multiSelectFieldList :: (Eq a, RenderMessage site msg)
@@ -512,31 +533,58 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
 radioField :: (Eq a, RenderMessage site FormMessage)
            => HandlerFor site (OptionList a)
            -> Field (HandlerFor site) a
-radioField = selectFieldHelper
-    (\theId _name _attrs inside -> [whamlet|
+radioField = withRadioField
+    (\theId optionWidget -> [whamlet|
 $newline never
-<div ##{theId}>^{inside}
+<div .radio>
+    <label for=#{theId}-none>
+        <div>
+            ^{optionWidget}
+            _{MsgSelectNone}
 |])
-    (\theId name isSel -> [whamlet|
+    (\theId value _isSel text optionWidget -> [whamlet|
 $newline never
-<label .radio for=#{theId}-none>
-    <div>
-        <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
-        _{MsgSelectNone}
+<div .radio>
+    <label for=#{theId}-#{value}>
+        <div>
+            ^{optionWidget}
+            \#{text}
 |])
-    (\theId name attrs value isSel text -> [whamlet|
+
+
+-- | Allows the user to place the option radio widget somewhere in
+--   the template.
+--   For example: If you want a table of radio options to select.
+--   'radioField' is an example on how to use this function.
+--
+--   @since 1.7.2
+withRadioField :: (Eq a, RenderMessage site FormMessage)
+           => (Text -> WidgetFor site ()-> WidgetFor site ()) -- ^ nothing case for mopt
+           -> (Text ->  Text -> Bool -> Text -> WidgetFor site () -> WidgetFor site ()) -- ^ cases for values
+           -> HandlerFor site (OptionList a)
+           -> Field (HandlerFor site) a
+withRadioField nothingFun optFun =
+  selectFieldHelper outside onOpt inside Nothing
+  where
+    outside theId _name _attrs inside' = [whamlet|
 $newline never
-<label .radio for=#{theId}-#{value}>
-    <div>
-        <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
-        \#{text}
-|])
+<div ##{theId}>^{inside'}
+|]
+    onOpt theId name isSel = nothingFun theId $ [whamlet|
+$newline never
+<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
+|]
+    inside theId name attrs value isSel display =
+       optFun theId value isSel display [whamlet|
+<input id=#{theId}-#{(value)} type=radio name=#{name} value=#{(value)} :isSel:checked *{attrs}>
+|]
+
 
 -- | Creates a group of radio buttons to answer the question given in the message. Radio buttons are used to allow differentiating between an empty response (@Nothing@) and a no response (@Just False@). Consider using the simpler 'checkBoxField' if you don't need to make this distinction.
 --
 -- If this field is optional, the first radio button is labeled "\<None>", the second \"Yes" and the third \"No".
 --
--- If this field is required, the first radio button is labeled \"Yes" and the second \"No". 
+-- If this field is required, the first radio button is labeled \"Yes" and the second \"No".
 --
 -- (Exact label titles will depend on localization).
 boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
@@ -570,7 +618,7 @@ $newline never
       t -> Left $ SomeMessage $ MsgInvalidBool t
     showVal = either (\_ -> False)
 
--- | Creates an input with @type="checkbox"@. 
+-- | Creates an input with @type="checkbox"@.
 --   While the default @'boolField'@ implements a radio button so you
 --   can differentiate between an empty response (@Nothing@) and a no
 --   response (@Just False@), this simpler checkbox field returns an empty
@@ -598,15 +646,31 @@ $newline never
         showVal = either (\_ -> False)
 
 -- | A structure holding a list of options. Typically you can use a convenience function like 'mkOptionList' or 'optionsPairs' instead of creating this directly.
-data OptionList a = OptionList
+--
+-- Extended by 'OptionListGrouped' in 1.7.0.
+data OptionList a
+  = OptionList
     { olOptions :: [Option a]
     , olReadExternal :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue').
     }
+  | OptionListGrouped
+    { olOptionsGrouped :: [(Text, [Option a])]
+    , olReadExternalGrouped :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue').
+    }
 
--- | Since 1.4.6
+-- | Convert grouped 'OptionList' to a normal one.
+--
+-- @since 1.7.0
+flattenOptionList :: OptionList a -> OptionList a
+flattenOptionList (OptionListGrouped os re) = OptionList (concatMap snd os) re
+flattenOptionList ol = ol
+
+-- | @since 1.4.6
 instance Functor OptionList where
-    fmap f (OptionList options readExternal) = 
+    fmap f (OptionList options readExternal) =
       OptionList ((fmap.fmap) f options) (fmap f . readExternal)
+    fmap f (OptionListGrouped options readExternal) =
+      OptionListGrouped (map (\(g, os) -> (g, (fmap.fmap) f os)) options) (fmap f . readExternal)
 
 -- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternal' function.
 mkOptionList :: [Option a] -> OptionList a
@@ -615,13 +679,22 @@ mkOptionList os = OptionList
     , olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os
     }
 
+-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternalGrouped' function.
+--
+-- @since 1.7.0
+mkOptionListGrouped :: [(Text, [Option a])] -> OptionList a
+mkOptionListGrouped os = OptionListGrouped
+    { olOptionsGrouped = os
+    , olReadExternalGrouped = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) $ concatMap snd os
+    }
+
 data Option a = Option
     { optionDisplay :: Text -- ^ The user-facing label.
     , optionInternalValue :: a -- ^ The Haskell value being selected.
     , optionExternalValue :: Text -- ^ The representation of this value stored in the form.
     }
 
--- | Since 1.4.6
+-- | @since 1.4.6
 instance Functor Option where
     fmap f (Option display internal external) = Option display (f internal) external
 
@@ -637,6 +710,30 @@ optionsPairs opts = do
                  }
   return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
 
+-- | Creates an 'OptionList' from a list of (display-value, internal value) pairs.
+--
+-- @since 1.7.0
+optionsPairsGrouped
+  :: forall m msg a. (MonadHandler m, RenderMessage (HandlerSite m) msg)
+  => [(msg, [(msg, a)])] -> m (OptionList a)
+optionsPairsGrouped opts = do
+  mr <- getMessageRender
+  let mkOption (external, (display, internal)) =
+          Option { optionDisplay       = mr display
+                 , optionInternalValue = internal
+                 , optionExternalValue = pack $ show external
+                 }
+      opts' = enumerateSublists opts :: [(msg, [(Int, (msg, a))])]
+      opts'' = map (\(x, ys) -> (mr x, map mkOption ys)) opts'
+  return $ mkOptionListGrouped opts''
+
+-- | Helper to enumerate sublists with one consecutive index.
+enumerateSublists :: forall a b. [(a, [b])] -> [(a, [(Int, b)])]
+enumerateSublists xss =
+  let yss :: [(Int, (a, [b]))]
+      yss = snd $ foldl (\(i, res) xs -> (i + (length.snd) xs, res ++ [(i, xs)])) (1, []) xss
+   in map (\(i, (x, ys)) -> (x, zip [i :: Int ..] ys)) yss
+
 -- | Creates an 'OptionList' from an 'Enum', using its 'Show' instance for the user-facing value.
 optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
 optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
@@ -692,7 +789,7 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
 -- | An alternative to 'optionsPersist' which returns just the 'Key' instead of
 -- the entire 'Entity'.
 --
--- Since 1.3.2
+-- @since 1.3.2
 #if MIN_VERSION_persistent(2,5,0)
 optionsPersistKey
   :: (YesodPersist site
@@ -731,7 +828,7 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
         }) pairs
 
 -- |
--- A helper function for constucting 'selectField's. You may want to use this when you define your custom 'selectField's or 'radioField's.
+-- A helper function for constucting 'selectField's with optional option groups. You may want to use this when you define your custom 'selectField's or 'radioField's.
 --
 -- @since 1.6.2
 selectFieldHelper
@@ -739,23 +836,26 @@ selectFieldHelper
         => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()) -- ^ Outermost part of the field
         -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional
         -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options
+        -> (Maybe (Text -> WidgetFor site ())) -- ^ Group headers placed inbetween options
         -> HandlerFor site (OptionList a)
         -> Field (HandlerFor site) a
-selectFieldHelper outside onOpt inside opts' = Field
+selectFieldHelper outside onOpt inside grpHdr opts' = Field
     { fieldParse = \x _ -> do
-        opts <- opts'
+        opts <- fmap flattenOptionList opts'
         return $ selectParser opts x
     , fieldView = \theId name attrs val isReq -> do
-        opts <- fmap olOptions $ handlerToWidget opts'
         outside theId name attrs $ do
-            unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
-            flip mapM_ opts $ \opt -> inside
-                theId
-                name
-                ((if isReq then (("required", "required"):) else id) attrs)
-                (optionExternalValue opt)
-                ((render opts val) == optionExternalValue opt)
-                (optionDisplay opt)
+          optsFlat <- fmap (olOptions.flattenOptionList) $ handlerToWidget opts'
+          unless isReq $ onOpt theId name $ render optsFlat val `notElem` map optionExternalValue optsFlat
+          opts'' <- handlerToWidget opts'
+          case opts'' of
+            OptionList{} -> constructOptions theId name attrs val isReq optsFlat
+            OptionListGrouped{olOptionsGrouped=grps} -> do
+                  forM_ grps $ \(grp, opts) -> do
+                    case grpHdr of
+                      Just hdr -> hdr grp
+                      Nothing -> return ()
+                    constructOptions theId name attrs val isReq opts
     , fieldEnctype = UrlEncoded
     }
   where
@@ -768,6 +868,14 @@ selectFieldHelper outside onOpt inside opts' = Field
             x -> case olReadExternal opts x of
                     Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
                     Just y -> Right $ Just y
+    constructOptions theId name attrs val isReq opts =
+      forM_ opts $ \opt -> inside
+                           theId
+                           name
+                           ((if isReq then (("required", "required"):) else id) attrs)
+                           (optionExternalValue opt)
+                           (render opts val == optionExternalValue opt)
+                           (optionDisplay opt)
 
 -- | Creates an input with @type="file"@.
 fileField :: Monad m
@@ -864,11 +972,52 @@ prependZero t0 = if T.null t1
                            then "-0." `T.append` (T.drop 2 t1)
                            else t1
 
-  where t1 = T.dropWhile ((==) ' ') t0
+  where t1 = T.dropWhile (==' ') t0
 
 -- $optionsOverview
 -- These functions create inputs where one or more options can be selected from a list.
--- 
+--
 -- The basic datastructure used is an 'Option', which combines a user-facing display value, the internal Haskell value being selected, and an external 'Text' stored as the @value@ in the form (used to map back to the internal value). A list of these, together with a function mapping from an external value back to a Haskell value, form an 'OptionList', which several of these functions take as an argument.
--- 
+--
 -- Typically, you won't need to create an 'OptionList' directly and can instead make one with functions like 'optionsPairs' or 'optionsEnum'. Alternatively, you can use functions like 'selectFieldList', which use their @[(msg, a)]@ parameter to create an 'OptionList' themselves.
+
+-- | Creates an input with @type="color"@.
+--   The input value must be provided in hexadecimal format #rrggbb.
+--
+-- @since 1.7.1
+colorField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
+colorField = Field
+    { fieldParse = parseHelper $ \s ->
+        if isHexColor $ unpack s then Right s
+        else Left $ MsgInvalidHexColorFormat s
+    , fieldView = \theId name attrs val _ -> [whamlet|
+$newline never
+<input ##{theId} name=#{name} *{attrs} type=color value=#{either id id val}>
+|]
+    , fieldEnctype = UrlEncoded
+    }
+  where
+      isHexColor :: String -> Bool
+      isHexColor ['#',a,b,c,d,e,f] = all isHexDigit [a,b,c,d,e,f]
+      isHexColor _ = False
+
+-- | Creates an input with @type="datetime-local"@.
+--   The input value must be provided in YYYY-MM-DD(T| )HH:MM[:SS] format.
+--
+-- @since 1.7.6
+datetimeLocalField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m LocalTime
+datetimeLocalField = Field
+    { fieldParse = parseHelper $ \s -> case T.split (\c -> (c == 'T') || (c == ' ')) s of
+        [d,t] -> do
+            day <- parseDate $ unpack d
+            time <- parseTime t
+            Right $ LocalTime day time
+        _ -> Left $ MsgInvalidDatetimeFormat s
+    , fieldView = \theId name attrs val isReq -> [whamlet|
+$newline never
+<input type=datetime-local ##{theId} name=#{name} value=#{showVal val} *{attrs} :isReq:required>
+|]
+    , fieldEnctype = UrlEncoded
+    }
+  where
+    showVal = either id (pack . show)

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

@@ -24,3 +24,5 @@ chineseFormMessage (MsgInvalidBool t) = "无效的逻辑值: " `mappend` t
 chineseFormMessage MsgBoolYes = "是"
 chineseFormMessage MsgBoolNo = "否"
 chineseFormMessage MsgDelete = "删除?"
+chineseFormMessage (MsgInvalidHexColorFormat t) = "颜色无效，必须为 #rrggbb 十六进制格式: " `mappend` t
+chineseFormMessage (MsgInvalidDatetimeFormat t) = "日期時間無效，必須採用 YYYY-MM-DD(T| )HH:MM[:SS] 格式： " `mappend` t

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

@@ -24,3 +24,5 @@ croatianFormMessage (MsgInvalidBool t)    = "Logička vrijednost nije valjana: "
 croatianFormMessage MsgBoolYes            = "Da"
 croatianFormMessage MsgBoolNo             = "Ne"
 croatianFormMessage MsgDelete             = "Izbrisati?"
+croatianFormMessage (MsgInvalidHexColorFormat t) = "Nevažeća boja, mora biti u #rrggbb heksadecimalnom formatu: " `mappend` t
+croatianFormMessage (MsgInvalidDatetimeFormat t) = "Nevažeći datum i vrijeme, mora biti u formatu GGGG-MM-DD(T| )HH:MM[:SS]: " `mappend` t

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

@@ -24,3 +24,5 @@ czechFormMessage (MsgInvalidBool t) = "Neplatná pravdivostní hodnota: " `mappe
 czechFormMessage MsgBoolYes = "Ano"
 czechFormMessage MsgBoolNo = "Ne"
 czechFormMessage MsgDelete = "Smazat?"
+czechFormMessage (MsgInvalidHexColorFormat t) = "Neplatná barva, musí být v #rrggbb hexadecimálním formátu: " `mappend` t
+czechFormMessage (MsgInvalidDatetimeFormat t) = "Neplatné datum a čas, musí být ve formátu YYYY-MM-DD(T| )HH:MM[:SS]: " `mappend` t

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

@@ -24,3 +24,5 @@ dutchFormMessage (MsgInvalidBool t)    = "Ongeldige waarheidswaarde: " `mappend`
 dutchFormMessage MsgBoolYes            = "Ja"
 dutchFormMessage MsgBoolNo             = "Nee"
 dutchFormMessage MsgDelete             = "Verwijderen?"
+dutchFormMessage (MsgInvalidHexColorFormat t) = "Ongeldige kleur, moet de hexadecimale indeling #rrggbb hebben: " `mappend` t
+dutchFormMessage (MsgInvalidDatetimeFormat t) = "Ongeldige datum/tijd, moet de indeling JJJJ-MM-DD(T| )UU:MM[:SS] hebben: " `mappend` t

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

@@ -24,3 +24,5 @@ englishFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t
 englishFormMessage MsgBoolYes = "Yes"
 englishFormMessage MsgBoolNo = "No"
 englishFormMessage MsgDelete = "Delete?"
+englishFormMessage (MsgInvalidHexColorFormat t) = "Invalid color, must be in #rrggbb hexadecimal format: " `mappend` t
+englishFormMessage (MsgInvalidDatetimeFormat t) = "Invalid datetime, must be in YYYY-MM-DD(T| )HH:MM[:SS] format: " `mappend` t

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

@@ -24,3 +24,5 @@ frenchFormMessage (MsgInvalidBool t) = "Booléen invalide : " `mappend` t
 frenchFormMessage MsgBoolYes = "Oui"
 frenchFormMessage MsgBoolNo = "Non"
 frenchFormMessage MsgDelete = "Détruire ?"
+frenchFormMessage (MsgInvalidHexColorFormat t) = "Couleur non valide. doit être au format hexadécimal #rrggbb : " `mappend` t
+frenchFormMessage (MsgInvalidDatetimeFormat t) = "Date/heure non valide. doit être au format AAAA-MM-JJ(T| )HH:MM[:SS] : " `mappend` t

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

@@ -24,3 +24,5 @@ germanFormMessage (MsgInvalidBool t) = "Ungültiger Wahrheitswert: " `mappend` t
 germanFormMessage MsgBoolYes = "Ja"
 germanFormMessage MsgBoolNo = "Nein"
 germanFormMessage MsgDelete = "Löschen?"
+germanFormMessage (MsgInvalidHexColorFormat t) = "Ungültige Farbe, muss im Hexadezimalformat #rrggbb vorliegen: " `mappend` t
+germanFormMessage (MsgInvalidDatetimeFormat t) = "Ungültige Datums- und Uhrzeitangabe, muss im Format YYYY-MM-DD(T| )HH:MM[:SS] vorliegen: " `mappend` t

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

@@ -24,3 +24,5 @@ japaneseFormMessage (MsgInvalidBool t) = "無効なbool値です: " `mappend` t
 japaneseFormMessage MsgBoolYes = "はい"
 japaneseFormMessage MsgBoolNo = "いいえ"
 japaneseFormMessage MsgDelete = "削除しますか?"
+japaneseFormMessage (MsgInvalidHexColorFormat t) = "無効な色。＃rrggbb16進形式である必要があります: " `mappend` t
+japaneseFormMessage (MsgInvalidDatetimeFormat t) = "無効な日時です。YYYY-MM-DD(T| )HH:MM[:SS] 形式である必要があります: " `mappend` t

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

@@ -24,3 +24,5 @@ koreanFormMessage (MsgInvalidBool t) = "잘못된 불(boolean)입니다: " `mapp
 koreanFormMessage MsgBoolYes = "예"
 koreanFormMessage MsgBoolNo = "아니오"
 koreanFormMessage MsgDelete = "삭제하시겠습니까?"
+koreanFormMessage (MsgInvalidHexColorFormat t) = "색상이 잘못되었습니다. #rrggbb 16진수 형식이어야 합니다.: " `mappend` t
+koreanFormMessage (MsgInvalidDatetimeFormat t) = "날짜/시간이 잘못되었습니다. YYYY-MM-DD(T| )HH:MM[:SS] 형식이어야 합니다.: " `mappend` t

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

@@ -24,3 +24,5 @@ norwegianBokmålFormMessage MsgBoolYes = "Ja"
 norwegianBokmålFormMessage MsgBoolNo = "Nei"
 norwegianBokmålFormMessage MsgDelete = "Slette?"
 norwegianBokmålFormMessage MsgCsrfWarning = "Som beskyttelse mot «cross-site request forgery»-angrep, vennligst bekreft innsendt skjema."
+norwegianBokmålFormMessage (MsgInvalidHexColorFormat t) = "Ugyldig farge, må være i #rrggbb heksadesimalt format: " `mappend` t
+norwegianBokmålFormMessage (MsgInvalidDatetimeFormat t) = "Ugyldig datoklokkeslett, må være i formatet ÅÅÅÅ-MM-DD(T| )HH:MM[:SS]:" `mappend` t

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

@@ -24,3 +24,5 @@ portugueseFormMessage (MsgInvalidBool t) = "Booleano inválido: " `mappend` t
 portugueseFormMessage MsgBoolYes = "Sim"
 portugueseFormMessage MsgBoolNo = "Não"
 portugueseFormMessage MsgDelete = "Remover?"
+portugueseFormMessage (MsgInvalidHexColorFormat t) = "Cor inválida, deve estar no formato #rrggbb hexadecimal: " `mappend` t
+portugueseFormMessage (MsgInvalidDatetimeFormat t) = "Data e hora inválida, deve estar no formato AAAA-MM-DD(T| )HH:MM[:SS]: " `mappend` t

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

@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Form.I18n.Romanian where
+
+import Yesod.Form.Types (FormMessage (..))
+import Data.Monoid (mappend)
+import Data.Text (Text)
+
+-- | Romanian translation
+--
+-- @since 1.7.5
+romanianFormMessage :: FormMessage -> Text
+romanianFormMessage (MsgInvalidInteger t) = "Număr întreg nevalid: " `Data.Monoid.mappend` t
+romanianFormMessage (MsgInvalidNumber t) = "Număr nevalid: " `mappend` t
+romanianFormMessage (MsgInvalidEntry t) = "Valoare nevalidă: " `mappend` t
+romanianFormMessage MsgInvalidTimeFormat = "Oră nevalidă. Formatul necesar este HH:MM[:SS]"
+romanianFormMessage MsgInvalidDay = "Dată nevalidă. Formatul necesar este AAAA-LL-ZZ"
+romanianFormMessage (MsgInvalidUrl t) = "Adresă URL nevalidă: " `mappend` t
+romanianFormMessage (MsgInvalidEmail t) = "Adresă de e-mail nevalidă: " `mappend` t
+romanianFormMessage (MsgInvalidHour t) = "Oră nevalidă: " `mappend` t
+romanianFormMessage (MsgInvalidMinute t) = "Minut nevalid: " `mappend` t
+romanianFormMessage (MsgInvalidSecond t) = "Secundă nevalidă: " `mappend` t
+romanianFormMessage MsgCsrfWarning = "Ca protecție împotriva atacurilor CSRF, vă rugăm să confirmați trimiterea formularului."
+romanianFormMessage MsgValueRequired = "Câmp obligatoriu"
+romanianFormMessage (MsgInputNotFound t) = "Valoare inexistentă: " `mappend` t
+romanianFormMessage MsgSelectNone = "<Niciuna>"
+romanianFormMessage (MsgInvalidBool t) = "Valoare booleană nevalidă: " `mappend` t
+romanianFormMessage MsgBoolYes = "Da"
+romanianFormMessage MsgBoolNo = "Nu"
+romanianFormMessage MsgDelete = "Șterge?"
+romanianFormMessage (MsgInvalidHexColorFormat t) = "Culoare nevalidă. Formatul necesar este #rrggbb în hexazecimal: " `mappend` t
+romanianFormMessage (MsgInvalidDatetimeFormat t) = "Data și ora nevalidă, trebuie să fie în format AAAA-LL-ZZ(T| )HH:MM[:SS]: " `mappend` t

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

@@ -24,3 +24,5 @@ russianFormMessage (MsgInvalidBool t) = "Неверное логическое
 russianFormMessage MsgBoolYes = "Да"
 russianFormMessage MsgBoolNo = "Нет"
 russianFormMessage MsgDelete = "Удалить?"
+russianFormMessage (MsgInvalidHexColorFormat t) = "Недопустимое значение цвета, должен быть в шестнадцатеричном формате #rrggbb: " `mappend` t
+russianFormMessage (MsgInvalidDatetimeFormat t) = "Недопустимое значение даты и времени. Должно быть в формате ГГГГ-ММ-ДД(T| )ЧЧ:ММ[:СС]: " `mappend` t

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

@@ -25,3 +25,5 @@ spanishFormMessage (MsgInvalidBool t) = "Booleano inválido: " `mappend` t
 spanishFormMessage MsgBoolYes = "Sí"
 spanishFormMessage MsgBoolNo = "No"
 spanishFormMessage MsgDelete = "¿Eliminar?"
+spanishFormMessage (MsgInvalidHexColorFormat t) = "Color no válido, debe estar en formato hexadecimal #rrggbb: " `mappend` t
+spanishFormMessage (MsgInvalidDatetimeFormat t) = "Fecha y hora no válida; debe estar en formato AAAA-MM-DD(T| )HH:MM[:SS]: " `mappend` t

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

@@ -24,3 +24,5 @@ swedishFormMessage MsgBoolYes = "Ja"
 swedishFormMessage MsgBoolNo = "Nej"
 swedishFormMessage MsgDelete = "Radera?"
 swedishFormMessage MsgCsrfWarning = "Som skydd mot \"cross-site request forgery\" attacker, vänligen bekräfta skickandet av formuläret."
+swedishFormMessage (MsgInvalidHexColorFormat t) = "Ogiltig färg, måste vara i #rrggbb hexadecimalt format: " `mappend` t
+swedishFormMessage (MsgInvalidDatetimeFormat t) = "Ogiltig datumtid, måste vara i formatet ÅÅÅÅ-MM-DD(T| )TT:MM[:SS]: " `mappend` t

yesod-form/Yesod/Form/Types.hs

@@ -166,6 +166,18 @@ instance Monad m => Applicative (AForm m) where
         (a, b, ints', c) <- f mr env ints
         (x, y, ints'', z) <- g mr env ints'
         return (a <*> x, b . y, ints'', c `mappend` z)
+
+#if MIN_VERSION_transformers(0,6,0)
+instance Monad m => Monad (AForm m) where
+    (AForm f) >>= k = AForm $ \mr env ints -> do
+        (a, b, ints', c) <- f mr env ints
+        case a of
+          FormSuccess r -> do 
+            (x, y, ints'', z) <- unAForm (k r) mr env ints'
+            return (x, b . y, ints'', c `mappend` z)
+          FormFailure err -> pure (FormFailure err, b, ints', c)
+          FormMissing -> pure (FormMissing, b, ints', c)
+#endif
 instance (Monad m, Monoid a) => Monoid (AForm m a) where
     mempty = pure mempty
     mappend a b = mappend <$> a <*> b
@@ -229,4 +241,6 @@ data FormMessage = MsgInvalidInteger Text
                  | MsgBoolYes
                  | MsgBoolNo
                  | MsgDelete
+                 | MsgInvalidHexColorFormat Text
+                 | MsgInvalidDatetimeFormat Text
     deriving (Show, Eq, Read)

yesod-form/yesod-form.cabal

@@ -1,5 +1,6 @@
+cabal-version:   >= 1.10
 name:            yesod-form
-version:         1.6.7
+version:         1.7.6
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -7,10 +8,9 @@ maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        Form handling support for Yesod Web Framework
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
-description:     API docs and the README are available at <http://www.stackage.org/package/yesod-form>.  Third-party packages which you can find useful: <http://hackage.haskell.org/package/yesod-form-richtext yesod-form-richtext> - richtext form fields (currntly it provides only Summernote support).
+description:     API docs and the README are available at <http://www.stackage.org/package/yesod-form>.  Third-party packages which you can find useful: <http://hackage.haskell.org/package/yesod-form-richtext yesod-form-richtext> - richtext form fields (currently it provides only Summernote support).
 extra-source-files: ChangeLog.md
                     README.md
 
@@ -19,6 +19,7 @@ flag network-uri
   default: True
 
 library
+    default-language: Haskell2010
     build-depends:   base                  >= 4.10     && < 5
                    , aeson
                    , attoparsec            >= 0.10
@@ -66,10 +67,12 @@ library
                      Yesod.Form.I18n.Spanish
                      Yesod.Form.I18n.Chinese
                      Yesod.Form.I18n.Korean
+                     Yesod.Form.I18n.Romanian
                      -- FIXME Yesod.Helpers.Crud
     ghc-options:     -Wall
 
 test-suite test
+    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: main.hs
     hs-source-dirs: test

yesod-persistent/ChangeLog.md

@@ -1,5 +1,17 @@
 # ChangeLog for yesod-persistent
 
+## 1.6.0.8
+
+* Add support for `persistent-2.14` [#1706](https://github.com/yesodweb/yesod/pull/1760)
+
+## 1.6.0.7
+
+* Add support for persistent 2.13. [#1723](https://github.com/yesodweb/yesod/pull/1723)
+
+## 1.6.0.6
+
+* Add support for persistent 2.12
+
 ## 1.6.0.5
 
 * Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)

yesod-persistent/Yesod/Persist/Core.hs

@@ -25,6 +25,7 @@ module Yesod.Persist.Core
 import Database.Persist
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 
+import Data.Foldable (toList)
 import Yesod.Core
 import Data.Conduit
 import Blaze.ByteString.Builder (Builder)
@@ -33,6 +34,12 @@ import Control.Monad.Trans.Resource
 import Control.Exception (throwIO)
 import Yesod.Core.Types (HandlerContents (HCError))
 import qualified Database.Persist.Sql as SQL
+#if MIN_VERSION_persistent(2,13,0)
+import qualified Database.Persist.SqlBackend.Internal as SQL
+#endif
+#if MIN_VERSION_persistent(2,14,0)
+import Database.Persist.Class.PersistEntity
+#endif
 
 unSqlPersistT :: a -> a
 unSqlPersistT = id
@@ -183,26 +190,46 @@ getBy404 key = do
 -- is violated.
 --
 -- @since 1.4.1
-#if MIN_VERSION_persistent(2,5,0)
-insert400 :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend)
-          => val
-          -> ReaderT backend m (Key val)
+#if MIN_VERSION_persistent(2,14,0)
+insert400
+    :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend, SafeToInsert val)
+    => val
+    -> ReaderT backend m (Key val)
+#elif MIN_VERSION_persistent(2,5,0)
+insert400
+    :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend)
+    => val
+    -> ReaderT backend m (Key val)
 #else
-insert400 :: (MonadIO m, PersistUnique (PersistEntityBackend val), PersistEntity val)
-          => val
-          -> ReaderT (PersistEntityBackend val) m (Key val)
+insert400
+    :: (MonadIO m, PersistUnique (PersistEntityBackend val), PersistEntity val)
+    => val
+    -> ReaderT (PersistEntityBackend val) m (Key val)
 #endif
 insert400 datum = do
     conflict <- checkUnique datum
     case conflict of
         Just unique ->
+#if MIN_VERSION_persistent(2, 12, 0)
+-- toList is called here because persistent-2.13 changed this
+-- to a nonempty list. for versions of persistent prior to 2.13, toList
+-- will be a no-op. for persistent-2.13, it'll convert the NonEmptyList to
+-- a List.
+            badRequest' $ map (unFieldNameHS . fst) $ toList $ persistUniqueToFieldNames unique
+#else
             badRequest' $ map (unHaskellName . fst) $ persistUniqueToFieldNames unique
+#endif
         Nothing -> insert datum
 
 -- | Same as 'insert400', but doesn’t return a key.
 --
 -- @since 1.4.1
-#if MIN_VERSION_persistent(2,5,0)
+#if MIN_VERSION_persistent(2,14,0)
+insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend, SafeToInsert val)
+           => val
+           -> ReaderT backend m ()
+
+#elif MIN_VERSION_persistent(2,5,0)
 insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend)
            => val
            -> ReaderT backend m ()

yesod-persistent/yesod-persistent.cabal

@@ -1,6 +1,6 @@
 cabal-version:   >= 1.10
 name:            yesod-persistent
-version:         1.6.0.5
+version:         1.6.0.8
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -17,8 +17,8 @@ library
     default-language: Haskell2010
     build-depends:   base                      >= 4.10     && < 5
                    , yesod-core                >= 1.6      && < 1.7
-                   , persistent                >= 2.8      && < 2.12
-                   , persistent-template       >= 2.1      && < 2.10
+                   , persistent                >= 2.8
+                   , persistent-template       >= 2.1
                    , transformers              >= 0.2.2
                    , blaze-builder
                    , conduit
@@ -34,6 +34,7 @@ test-suite test
     main-is: Spec.hs
     hs-source-dirs: test
     other-modules: Yesod.PersistSpec
+    build-tool-depends: hspec-discover:hspec-discover
     build-depends: base
                  , hspec
                  , wai-extra

yesod-test/ChangeLog.md

@@ -1,5 +1,33 @@
 # ChangeLog for yesod-test
 
+
+## 1.6.16
+
+* Add `addBareGetParam` to yesod-test. [#1821](https://github.com/yesodweb/yesod/pull/1821)
+
+## 1.6.15
+
+* Add `bySelectorLabelContain`. [#1781](https://github.com/yesodweb/yesod/pull/1781)
+
+## 1.6.14
+
+* Fix quotes not matching in htmlContain* functions [#1768](https://github.com/yesodweb/yesod/pull/1768).
+* Add logging of the matches found of these functions [#1768](https://github.com/yesodweb/yesod/pull/1768).
+* Improved failure messages from `assertEq`. [#1767](https://github.com/yesodweb/yesod/pull/1767)
+
+## 1.6.13
+
+* Add `Yesod.Test.Internal.SIO` module to expose the `SIO` type.
+
+## 1.6.12
+
+* Fix import in cookie example [#1713](https://github.com/yesodweb/yesod/pull/1713)
+* Add `MonadState` instance for `SIO`
+
+## 1.6.11
+
+* Add missing `HasCallStack`s [#1710](https://github.com/yesodweb/yesod/pull/1710)
+
 ## 1.6.10
 
 * `statusIs` assertion failures now print a preview of the response body, if the response body is UTF-8 or ASCII. [#1680](https://github.com/yesodweb/yesod/pull/1680/files)

yesod-test/README.md

@@ -42,9 +42,9 @@ spec = withApp $ do
           addToken -- Add the CSRF _token field with the currently shown value.
 
           -- Lookup field by the text on the labels pointing to them.
-          byLabel "Email:" "gustavo@cerati.com"
-          byLabel "Password:" "secret"
-          byLabel "Confirm:" "secret"
+          byLabelExact "Email:" "gustavo@cerati.com"
+          byLabelExact "Password:" "secret"
+          byLabelExact "Confirm:" "secret"
 
       it "Sends another form, this one has a file" $ do
         request $ do

yesod-test/Yesod/Test.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 {-|
 Yesod.Test is a pragmatic framework for testing web applications built
@@ -151,6 +152,7 @@ module Yesod.Test
     , setMethod
     , addPostParam
     , addGetParam
+    , addBareGetParam
     , addFile
     , setRequestBody
     , RequestBuilder
@@ -169,6 +171,7 @@ module Yesod.Test
     , byLabelContain
     , byLabelPrefix
     , byLabelSuffix
+    , bySelectorLabelContain
     , fileByLabel
     , fileByLabelExact
     , fileByLabelContain
@@ -240,10 +243,10 @@ import qualified Network.Socket.Internal as Sock
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
+import qualified Text.Blaze.Renderer.String as Blaze
+import qualified Text.Blaze as Blaze
 import Network.Wai
 import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
-import Control.Monad.Trans.Reader (ReaderT (..))
-import Conduit (MonadThrow)
 import Control.Monad.IO.Class
 import System.IO
 import Yesod.Core.Unsafe (runFakeHandler)
@@ -255,7 +258,6 @@ import Text.XML.Cursor hiding (element)
 import qualified Text.XML.Cursor as C
 import qualified Text.HTML.DOM as HD
 import Control.Monad.Trans.Writer
-import Data.IORef
 import qualified Data.Map as M
 import qualified Web.Cookie as Cookie
 import qualified Blaze.ByteString.Builder as Builder
@@ -279,6 +281,7 @@ import Data.Aeson (FromJSON, eitherDecode')
 import Control.Monad (unless)
 
 import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8)
+import Yesod.Test.Internal.SIO
 
 {-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-}
 {-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-}
@@ -429,7 +432,7 @@ yit :: String -> YesodExample site () -> YesodSpec site
 yit label example = tell [YesodSpecItem label example]
 
 -- | Modifies the site ('yedSite') of the test, and creates a new WAI app ('yedApp') for it.
--- 
+--
 -- yesod-test allows sending requests to your application to test that it handles them correctly.
 -- In rare cases, you may wish to modify that application in the middle of a test.
 -- This may be useful if you wish to, for example, test your application under a certain configuration,
@@ -453,7 +456,7 @@ testModifySite :: YesodDispatch site
                => (site -> IO (site, Middleware)) -- ^ A function from the existing site, to a new site and middleware for a WAI app.
                -> YesodExample site ()
 testModifySite newSiteFn = do
-  currentSite <- getTestYesod 
+  currentSite <- getTestYesod
   (newSite, middleware) <- liftIO $ newSiteFn currentSite
   app <- liftIO $ toWaiAppPlain newSite
   modifySIO $ \yed -> yed { yedSite = newSite, yedApp = middleware app }
@@ -462,7 +465,7 @@ testModifySite newSiteFn = do
 --
 -- ==== __Examples__
 --
--- > import qualified Data.Cookie as Cookie
+-- > import qualified Web.Cookie as Cookie
 -- > :set -XOverloadedStrings
 -- > testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "name" }
 --
@@ -500,7 +503,8 @@ testClearCookies = do
 
 -- Performs a given action using the last response. Use this to create
 -- response-level assertions
-withResponse' :: (state -> Maybe SResponse)
+withResponse' :: HasCallStack
+              => (state -> Maybe SResponse)
               -> [T.Text]
               -> (SResponse -> SIO state a)
               -> SIO state a
@@ -514,7 +518,7 @@ withResponse' getter errTrace f = maybe err f . getter =<< getSIO
 
 -- | Performs a given action using the last response. Use this to create
 -- response-level assertions
-withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a
+withResponse :: HasCallStack => (SResponse -> YesodExample site a) -> YesodExample site a
 withResponse = withResponse' yedResponse []
 
 -- | Use HXT to parse a value from an HTML tag.
@@ -523,7 +527,8 @@ parseHTML :: HtmlLBS -> Cursor
 parseHTML html = fromDocument $ HD.parseLBS html
 
 -- | Query the last response using CSS selectors, returns a list of matched fragments
-htmlQuery' :: (state -> Maybe SResponse)
+htmlQuery' :: HasCallStack
+           => (state -> Maybe SResponse)
            -> [T.Text]
            -> Query
            -> SIO state [HtmlLBS]
@@ -533,7 +538,7 @@ htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQu
     Right matches -> return $ map (encodeUtf8 . TL.pack) matches
 
 -- | Query the last response using CSS selectors, returns a list of matched fragments
-htmlQuery :: Query -> YesodExample site [HtmlLBS]
+htmlQuery :: HasCallStack => Query -> YesodExample site [HtmlLBS]
 htmlQuery = htmlQuery' yedResponse []
 
 -- | Asserts that the two given values are equal.
@@ -543,10 +548,8 @@ htmlQuery = htmlQuery' yedResponse []
 -- @since 1.5.2
 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"
+  liftIO $ HUnit.assertEqual msg a b
+  where msg = "Assertion: " ++ m ++ "\n"
 
 -- | Asserts that the two given values are not equal.
 --
@@ -707,8 +710,13 @@ htmlAllContain query search = do
   matches <- htmlQuery query
   case matches of
     [] -> failure $ "Nothing matched css query: " <> query
-    _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $
-          DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
+    _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search  ++ " matches: " ++ show matches) $
+          DL.all (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
+
+-- | puts the search trough the same escaping as the matches are.
+--   this helps with matching on special characters
+escape :: String -> String
+escape = Blaze.renderMarkup . Blaze.string
 
 -- | Queries the HTML using a CSS selector, and passes if any matched
 -- element contains the given string.
@@ -725,8 +733,8 @@ htmlAnyContain query search = do
   matches <- htmlQuery query
   case matches of
     [] -> failure $ "Nothing matched css query: " <> query
-    _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search) $
-          DL.any (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
+    _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search ++ " matches: " ++ show matches) $
+          DL.any (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
 
 -- | Queries the HTML using a CSS selector, and fails if any matched
 -- element contains the given string (in other words, it is the logical
@@ -742,7 +750,7 @@ htmlAnyContain query search = do
 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
+  case DL.filter (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches) of
     [] -> return ()
     found -> failure $ "Found " <> T.pack (show $ length found) <>
                 " instances of " <> T.pack search <> " in " <> query <> " elements"
@@ -803,12 +811,12 @@ printBody = withResponse $ \ SResponse { simpleBody = b } ->
 -- > {-# LANGUAGE OverloadedStrings #-}
 -- > get HomeR
 -- > printMatches "h1" -- Prints all h1 tags
-printMatches :: Query -> YesodExample site ()
+printMatches :: HasCallStack => Query -> YesodExample site ()
 printMatches query = do
   matches <- htmlQuery query
   liftIO $ hPutStrLn stderr $ show matches
 
--- | Add a parameter with the given name and value to the request body. 
+-- | Add a parameter with the given name and value to the request body.
 -- This function can be called multiple times to add multiple parameters, and be mixed with calls to 'addFile'.
 --
 -- "Post parameter" is an informal description of what is submitted by making an HTTP POST with an HTML @\<form\>@.
@@ -842,6 +850,23 @@ addGetParam name value = modifySIO $ \rbd -> rbd
               : rbdGets rbd
     }
 
+-- | Add a bare parameter with the given name and no value to the query
+-- string. The parameter is added without an @=@ sign.
+--
+-- You can specify the entire query string literally by adding a single bare
+-- parameter and no other parameters.
+--
+-- @since 1.6.16
+-- 
+-- ==== __Examples__
+--
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- > request $ do
+-- >   addBareGetParam "key" -- Adds ?key to the URL
+addBareGetParam :: T.Text -> RequestBuilder site ()
+addBareGetParam name = modifySIO $ \rbd ->
+    rbd {rbdGets = (TE.encodeUtf8 name, Nothing) : rbdGets rbd}
+
 -- | Add a file to be posted with the current request.
 --
 -- Adding a file will automatically change your request content-type to be multipart/form-data.
@@ -863,16 +888,43 @@ addFile name path mimetype = do
 
 -- |
 -- This looks up the name of a field based on the contents of the label pointing to it.
-genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
+genericNameFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
 genericNameFromLabel match label = do
   mres <- fmap rbdResponse getSIO
   res <-
     case mres of
       Nothing -> failure "genericNameFromLabel: No response available"
       Just res -> return res
+  let body = simpleBody res
+  case genericNameFromHTML match label body of
+    Left e -> failure e
+    Right x -> pure x
+
+-- |
+-- This looks up the name of a field based on a CSS selector and the contents of the label pointing to it.
+genericNameFromSelectorLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> T.Text -> RequestBuilder site T.Text
+genericNameFromSelectorLabel match selector label = do
+  mres <- fmap rbdResponse getSIO
+  res <-
+    case mres of
+      Nothing -> failure "genericNameSelectorFromLabel: No response available"
+      Just res -> return res
+  let body = simpleBody res
+  html <-
+    case findBySelector body selector of
+        Left parseError -> failure $ "genericNameFromSelectorLabel: Parse error" <> T.pack parseError
+        Right [] -> failure $ "genericNameFromSelectorLabel: No fragments match selector " <> selector
+        Right [matchingFragment] -> pure $ BSL8.pack matchingFragment
+        Right _matchingFragments -> failure $ "genericNameFromSelectorLabel: Multiple fragments match selector " <> selector
+  case genericNameFromHTML match label html of
+    Left e -> failure e
+    Right x -> pure x
+
+genericNameFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text
+genericNameFromHTML match label html =
   let
-    body = simpleBody res
-    mlabel = parseHTML body
+    parsedHTML = parseHTML html
+    mlabel = parsedHTML
                 $// C.element "label"
                 >=> isContentMatch label
     mfor = mlabel >>= attribute "for"
@@ -881,26 +933,26 @@ genericNameFromLabel match label = do
         | x `match` T.concat (c $// content) = [c]
         | otherwise = []
 
-  case mfor of
+  in case mfor of
     for:[] -> do
-      let mname = parseHTML body
+      let mname = parsedHTML
                     $// attributeIs "id" for
                     >=> attribute "name"
       case mname of
-        "":_ -> failure $ T.concat
+        "":_ -> Left $ T.concat
             [ "Label "
             , label
             , " resolved to id "
             , for
             , " which was not found. "
             ]
-        name:_ -> return name
-        [] -> failure $ "No input with id " <> for
+        name:_ -> Right name
+        [] -> Left $ "No input with id " <> for
     [] ->
       case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of
-        [] -> failure $ "No label contained: " <> label
-        name:_ -> return name
-    _ -> failure $ "More than one label contained " <> label
+        [] -> Left $ "No label contained: " <> label
+        name:_ -> Right name
+    _ -> Left $ "More than one label contained " <> label
 
 byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
                  -> T.Text                     -- ^ The text contained in the @\<label>@.
@@ -910,6 +962,15 @@ byLabelWithMatch match label value = do
   name <- genericNameFromLabel match label
   addPostParam name value
 
+bySelectorLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
+                 -> T.Text                     -- ^ The CSS selector.
+                 -> T.Text                     -- ^ The text contained in the @\<label>@.
+                 -> T.Text                     -- ^ The value to set the parameter to.
+                 -> RequestBuilder site ()
+bySelectorLabelWithMatch match selector label value = do
+  name <- genericNameFromSelectorLabel match selector label
+  addPostParam name value
+
 -- How does this work for the alternate <label><input></label> syntax?
 
 -- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter
@@ -1023,6 +1084,18 @@ byLabelSuffix :: T.Text -- ^ The text in the @\<label>@.
               -> RequestBuilder site ()
 byLabelSuffix = byLabelWithMatch T.isSuffixOf
 
+-- |
+-- Note: This function throws an error if it finds multiple labels or if the
+-- CSS selector fails to parse, doesn't match any fragment, or matches multiple
+-- fragments.
+--
+-- @since 1.6.15
+bySelectorLabelContain :: T.Text -- ^ The CSS selector.
+               -> T.Text -- ^ The text in the @\<label>@.
+               -> T.Text -- ^ The value to set the parameter to.
+               -> RequestBuilder site ()
+bySelectorLabelContain = bySelectorLabelWithMatch T.isInfixOf
+
 fileByLabelWithMatch  :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
                       -> T.Text                     -- ^ The text contained in the @\<label>@.
                       -> FilePath                   -- ^ The path to the file.
@@ -1135,7 +1208,7 @@ fileByLabelSuffix = fileByLabelWithMatch T.isSuffixOf
 --
 -- > request $ do
 -- >   addToken_ "#formID"
-addToken_ :: Query -> RequestBuilder site ()
+addToken_ :: HasCallStack => Query -> RequestBuilder site ()
 addToken_ scope = do
   matches <- htmlQuery' rbdResponse ["Tried to get CSRF token with addToken'"] $ scope <> " input[name=_token][type=hidden][value]"
   case matches of
@@ -1149,7 +1222,7 @@ addToken_ scope = do
 --
 -- > request $ do
 -- >   addToken
-addToken :: RequestBuilder site ()
+addToken :: HasCallStack => RequestBuilder site ()
 addToken = addToken_ ""
 
 -- | Calls 'addTokenFromCookieNamedToHeaderNamed' with the 'defaultCsrfCookieName' and 'defaultCsrfHeaderName'.
@@ -1162,7 +1235,7 @@ addToken = addToken_ ""
 -- >   addTokenFromCookie
 --
 -- Since 1.4.3.2
-addTokenFromCookie :: RequestBuilder site ()
+addTokenFromCookie :: HasCallStack => RequestBuilder site ()
 addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName defaultCsrfHeaderName
 
 -- | Looks up the CSRF token stored in the cookie with the given name and adds it to the request headers. An error is thrown if the cookie can't be found.
@@ -1178,7 +1251,8 @@ addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName
 -- >   addTokenFromCookieNamedToHeaderNamed "cookieName" (CI "headerName")
 --
 -- Since 1.4.3.2
-addTokenFromCookieNamedToHeaderNamed :: ByteString -- ^ The name of the cookie
+addTokenFromCookieNamedToHeaderNamed :: HasCallStack
+                                     => ByteString -- ^ The name of the cookie
                                      -> CI ByteString -- ^ The name of the header
                                      -> RequestBuilder site ()
 addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
@@ -1201,7 +1275,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
 -- >   liftIO $ putStrLn $ "Cookies are: " ++ show cookies
 --
 -- Since 1.4.3.2
-getRequestCookies :: RequestBuilder site Cookies
+getRequestCookies :: HasCallStack => RequestBuilder site Cookies
 getRequestCookies = do
   requestBuilderData <- getSIO
   headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
@@ -1362,8 +1436,8 @@ setUrl url' = do
 -- > get "/foobar"
 -- > clickOn "a#idofthelink"
 --
--- @since 1.5.7 
-clickOn :: Yesod site => Query -> YesodExample site ()
+-- @since 1.5.7
+clickOn :: (HasCallStack, 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
@@ -1567,7 +1641,7 @@ parseSetCookies :: [H.Header] -> [Cookie.SetCookie]
 parseSetCookies headers = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ headers
 
 -- Yes, just a shortcut
-failure :: (MonadIO a) => T.Text -> a b
+failure :: (HasCallStack, MonadIO a) => T.Text -> a b
 failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error ""
 
 type TestApp site = (site, Middleware)
@@ -1591,27 +1665,3 @@ instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) whe
                 return ())
             params
             ($ ())
-
--- | State + IO
---
--- @since 1.6.0
-newtype SIO s a = SIO (ReaderT (IORef s) IO a)
-  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
-
-getSIO :: SIO s s
-getSIO = SIO $ ReaderT readIORef
-
-putSIO :: s -> SIO s ()
-putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
-
-modifySIO :: (s -> s) -> SIO s ()
-modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
-
-evalSIO :: SIO s a -> s -> IO a
-evalSIO (SIO (ReaderT f)) s = newIORef s >>= f
-
-execSIO :: SIO s () -> s -> IO s
-execSIO (SIO (ReaderT f)) s = do
-  ref <- newIORef s
-  f ref
-  readIORef ref

yesod-test/Yesod/Test/Internal/SIO.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | The 'SIO' type is used by "Yesod.Test" to provide exception-safe
+-- environment between requests and assertions.
+--
+-- This module is internal. Breaking changes to this module will not be
+-- reflected in the major version of this package.
+--
+-- @since 1.6.13
+module Yesod.Test.Internal.SIO where
+
+import Control.Monad.Trans.Reader (ReaderT (..))
+import Conduit (MonadThrow)
+import qualified Control.Monad.State.Class as MS
+import Yesod.Core
+import Data.IORef
+
+-- | State + IO
+--
+-- @since 1.6.0
+newtype SIO s a = SIO (ReaderT (IORef s) IO a)
+  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
+
+instance MS.MonadState s (SIO s)
+  where
+  get = getSIO
+  put = putSIO
+
+-- | Retrieve the current state in the 'SIO' type.
+--
+-- Equivalent to 'MS.get'
+--
+-- @since 1.6.13
+getSIO :: SIO s s
+getSIO = SIO $ ReaderT readIORef
+
+-- | Put the given @s@ into the 'SIO' state for later retrieval.
+--
+-- Equivalent to 'MS.put', but the value is evaluated to weak head normal
+-- form.
+--
+-- @since 1.6.13
+putSIO :: s -> SIO s ()
+putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
+
+-- | Modify the underlying @s@ state.
+--
+-- This is strict in the function used, and is equivalent to 'MS.modify''.
+--
+-- @since 1.6.13
+modifySIO :: (s -> s) -> SIO s ()
+modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
+
+-- | Run an 'SIO' action with the intial state @s@ provided, returning the
+-- result, and discard the final state.
+--
+-- @since 1.6.13
+evalSIO :: SIO s a -> s -> IO a
+evalSIO action =
+    fmap snd . runSIO action
+
+-- | Run an 'SIO' action with the initial state @s@ provided, returning the
+-- final state, and discarding the result.
+--
+-- @since 1.6.13
+execSIO :: SIO s () -> s -> IO s
+execSIO action =
+    fmap fst . runSIO action
+
+-- | Run an 'SIO' action with the initial state provided, returning both
+-- the result of the computation as well as the final state.
+--
+-- @since 1.6.13
+runSIO :: SIO s a -> s -> IO (s, a)
+runSIO (SIO (ReaderT f)) s = do
+    ref <- newIORef s
+    a <- f ref
+    s' <- readIORef ref
+    pure (s', a)

yesod-test/test/main.hs

@@ -29,13 +29,16 @@ import Yesod.Test.CssQuery
 import Yesod.Test.TransversingCSS
 import Text.XML
 import Data.Text (Text, pack)
+import Data.Char (toUpper)
 import Data.Monoid ((<>))
 import Control.Applicative
-import Network.Wai (pathInfo, requestHeaders)
+import Network.Wai (pathInfo, rawQueryString, requestHeaders)
 import Network.Wai.Test (SResponse(simpleBody))
+import Numeric (showHex)
 import Data.Maybe (fromMaybe)
 import Data.Either (isLeft, isRight)
 
+import Test.HUnit.Lang
 import Data.ByteString.Lazy.Char8 ()
 import qualified Data.Map as Map
 import qualified Text.HTML.DOM as HD
@@ -45,6 +48,7 @@ import Control.Monad.IO.Unlift (toIO)
 import qualified Web.Cookie as Cookie
 import Data.Maybe (isNothing)
 import qualified Data.Text as T
+import qualified Data.ByteString.Char8 as B8
 import Yesod.Test.Internal (contentTypeHeaderIsUtf8)
 
 parseQuery_ :: Text -> [[SelectorGroup]]
@@ -171,6 +175,27 @@ main = hspec $ do
                 statusIs 200
                 -- They pass through the server correctly.
                 bodyEquals "foo+bar%41<&baz"
+            yit "get params" $ do
+                get ("/query" :: Text)
+                statusIs 200
+                bodyEquals ""
+
+                request $ do
+                    setMethod "GET"
+                    setUrl $ LiteAppRoute ["query"]
+                    -- If value uses special characters,
+                    addGetParam "foo" "foo+bar%41<&baz"
+                    addBareGetParam "goo+car%41<&caz"
+                statusIs 200
+                -- They pass through the server correctly.
+                let pctEnc c = "%" <> (map toUpper $ showHex (fromEnum c) "")
+                    plus = pctEnc '+'
+                    pct  = pctEnc '%'
+                    lt   = pctEnc '<'
+                    amp  = pctEnc '&'
+                bodyEquals $ mconcat
+                  [ "goo", plus, "car", pct, "41", lt, amp, "caz",
+                    "&foo=foo", plus, "bar", pct, "41", lt, amp, "baz"]
             yit "labels" $ do
                 get ("/form" :: Text)
                 statusIs 200
@@ -202,9 +227,17 @@ main = hspec $ do
                 statusIs 200
                 htmlCount "p" 2
                 htmlAllContain "p" "Hello"
+                htmlAllContain "span" "O'Kon"
                 htmlAnyContain "p" "World"
                 htmlAnyContain "p" "Moon"
+                htmlAnyContain "p" "O'Kon"
                 htmlNoneContain "p" "Sun"
+
+                -- we found it so we know the
+                -- matching on quotes works for NoneContain
+                withRunInIO $ \runInIO ->
+                  shouldThrow (runInIO (htmlNoneContain "span" "O'Kon"))
+                  (\case HUnitFailure _ _ -> True)
             yit "finds the CSRF token by css selector" $ do
                 get ("/form" :: Text)
                 statusIs 200
@@ -221,7 +254,7 @@ main = hspec $ 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>"
+              bodyEquals "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon and <span>O'Kon</span></p></body></html>"
 
               get ("/htmlWithLink" :: Text)
               bad <- tryAny (clickOn "a#nonexistentlink")
@@ -310,6 +343,21 @@ main = hspec $ do
                     setUrl ("label-contain-error" :: Text)
                     byLabelContain "hobby" "fishing")
                 assertEq "failure wasn't called" (isLeft bad) True
+            yit "bySelectorLabelContain looks for the selector and label which contain the given label name" $ do
+                get ("/selector-label-contain" :: Text)
+                request $ do
+                    setMethod "POST"
+                    setUrl ("check-hobby" :: Text)
+                    bySelectorLabelContain "#hobby-container" "hobby" "fishing"
+                res <- maybe "Couldn't get response" simpleBody <$> getResponse
+                assertEq "hobby isn't set" res "fishing"
+            yit "bySelectorLabelContain throws an error if the selector matches multiple elements" $ do
+                get ("selector-label-contain-error" :: Text)
+                (bad :: Either SomeException ()) <- try (request $ do
+                    setMethod "POST"
+                    setUrl ("check-hobby" :: Text)
+                    bySelectorLabelContain "#hobby-container" "hobby" "fishing")
+                assertEq "failure wasn't called" (isLeft bad) True
             yit "byLabelPrefix matches over the prefix of the labels" $ do
                 get ("/label-prefix" :: Text)
                 request $ do
@@ -521,6 +569,8 @@ app = liteApp $ do
         case mfoo of
             Nothing -> error "No foo"
             Just foo -> return foo
+    onStatic "query" . dispatchTo $
+        T.pack . B8.unpack . rawQueryString <$> waiRequest
     onStatic "redirect301" $ dispatchTo $ redirectWith status301 ("/redirectTarget" :: Text) >> return ()
     onStatic "redirect303" $ dispatchTo $ redirectWith status303 ("/redirectTarget" :: Text) >> return ()
     onStatic "redirectTarget" $ dispatchTo $ return ("we have been successfully redirected" :: Text)
@@ -555,7 +605,7 @@ app = liteApp $ do
             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)
+        return ("<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon and <span>O'Kon</span></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)
@@ -567,6 +617,10 @@ app = liteApp $ do
         return ("<html><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></html>" :: Text)
     onStatic "label-contain-error" $ dispatchTo $
         return ("<html><label for='hobby'>XXXhobbyXXX</label><label for='hobby2'>XXXhobby2XXX</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)
+    onStatic "selector-label-contain" $ dispatchTo $
+        return ("<html><div><label for='hobby-1'>XXXhobbyXXX</label><input type='text' name='hobby-1' id='hobby-1'></div><div id='hobby-container'><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></div></html>" :: Text)
+    onStatic "selector-label-contain-error" $ dispatchTo $
+        return ("<html><div id='hobby-container'><label for='hobby-1'>XXXhobbyXXX</label><input type='text' name='hobby-1' id='hobby-1'></div><div id='hobby-container'><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></div></html>" :: Text)
     onStatic "label-prefix" $ dispatchTo $
         return ("<html><label for='hobby'>hobbyXXX</label><input type='text' name='hobby' id='hobby'></html>" :: Text)
     onStatic "label-prefix-error" $ dispatchTo $

yesod-test/yesod-test.cabal

@@ -1,5 +1,5 @@
 name:               yesod-test
-version:            1.6.10
+version:            1.6.16
 license:            MIT
 license-file:       LICENSE
 author:             Nubis <nubis@woobiz.com.ar>
@@ -34,17 +34,20 @@ library
                    , pretty-show               >= 1.6
                    , text
                    , time
+                   , mtl                       >= 2.0.0
                    , transformers              >= 0.2.2
                    , wai                       >= 3.0
                    , wai-extra
                    , xml-conduit               >= 1.0
                    , xml-types                 >= 0.3
                    , yesod-core                >= 1.6.17
+                   , blaze-markup
 
     exposed-modules: Yesod.Test
                      Yesod.Test.CssQuery
                      Yesod.Test.TransversingCSS
                      Yesod.Test.Internal
+                     Yesod.Test.Internal.SIO
     ghc-options:  -Wall
 
 test-suite test

yesod-websockets/ChangeLog.md

@@ -1,3 +1,7 @@
+## 0.3.0.4
+
+* Fixed examples to work with Template Haskell change in recent GHC versions ([#1790](https://github.com/yesodweb/yesod/pull/1790)).
+
 ## 0.3.0.3
 * Removed the use of the deprecated forkPingThread and replaced it with the recommended withPingThread. [#1700](https://github.com/yesodweb/yesod/pull/1700)
 

yesod-websockets/chat-with-multiple-channels.hs

@@ -0,0 +1,142 @@
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables #-}
+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.Monoid ((<>))
+import Control.Concurrent.STM.Lifted
+import Data.Text (Text)
+import qualified Data.Map as M
+import UnliftIO.Exception (try, SomeException)
+
+data App = App (TVar (M.Map Text (TChan Text, Int)))
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod App
+
+cleanupChannel :: (Eq a1, Num a1) => Maybe (a2, a1) -> Maybe (a2, a1)
+cleanupChannel Nothing = Nothing
+cleanupChannel (Just (writeChan, 1)) = Nothing
+cleanupChannel (Just c) = Just c
+
+userJoinedChannel :: Num b => Maybe (a, b) -> Maybe (a, b)
+userJoinedChannel Nothing = Nothing
+userJoinedChannel (Just (writeChan, numUsers)) = Just (writeChan, numUsers + 1)
+
+chatApp :: WebSocketsT Handler ()
+chatApp = do
+    sendTextData ("Welcome to the chat server, please enter your name." :: Text)
+    name <- receiveData
+    sendTextData $ "Welcome, " <> name <> ". Please enter your channel ID"
+    channelId <- receiveData
+    sendTextData $ name <> " just joined " <> channelId
+
+    App channelMapTVar <- getYesod
+
+    channelMap <- readTVarIO channelMapTVar
+
+    let maybeChan = M.lookup channelId channelMap
+
+    writeChan <- atomically $ case maybeChan of
+                                Nothing -> do
+                                    chan <- newBroadcastTChan
+                                    writeTVar channelMapTVar $ M.insert channelId (chan, 1) channelMap
+                                    return chan
+                                Just (writeChan, _) -> do
+                                    writeTVar channelMapTVar $ M.alter userJoinedChannel channelId channelMap
+                                    return writeChan
+
+    readChan <- atomically $ do
+        writeTChan writeChan $ name <> " has joined the chat"
+        dupTChan writeChan
+    (e :: Either SomeException ()) <- try $ race_
+        (forever $ atomically (readTChan readChan) >>= sendTextData)
+        (sourceWS $$ mapM_C (\msg ->
+            atomically $ writeTChan writeChan $ name <> ": " <> msg))
+
+    atomically $ case e of
+        Left _ -> do
+            -- clean up your resources when user disconnects here
+            let newChannelMap = M.alter cleanupChannel channelId channelMap
+            writeTVar channelMapTVar newChannelMap
+            writeTChan writeChan $ name <> " has left the chat"
+        Right () -> return ()
+
+getHomeR :: Handler Html
+getHomeR = do
+    webSockets chatApp
+    defaultLayout $ do
+        [whamlet|
+            <div #output>
+            <form #form>
+                <input #input autofocus>
+        |]
+        toWidget [lucius|
+            \#output {
+                width: 600px;
+                height: 400px;
+                border: 1px solid black;
+                margin-bottom: 1em;
+                p {
+                    margin: 0 0 0.5em 0;
+                    padding: 0 0 0.5em 0;
+                    border-bottom: 1px dashed #99aa99;
+                }
+            }
+            \#input {
+                width: 600px;
+                display: block;
+            }
+        |]
+        toWidget [julius|
+            var url = document.URL,
+                output = document.getElementById("output"),
+                form = document.getElementById("form"),
+                input = document.getElementById("input"),
+                conn;
+
+            url = url.replace("http:", "ws:").replace("https:", "wss:");
+            conn = new WebSocket(url);
+
+            conn.onmessage = function(e) {
+                var p = document.createElement("p");
+                p.appendChild(document.createTextNode(e.data));
+                output.appendChild(p);
+            };
+/* ******************************************************************************************************* 
+The following code demonstrates one way to prevent timeouts. The "if" test is added to prevent chat participants from getting the ping message “dcba” every twenty seconds. It also prevents participants from receiving any message ending with “dcba” sent by any chat participant. “ e.data.split("").reverse().join("").substring(0,4)” changes, for example, “user:abc123dcba” to “abcd321cba:resu” and grabs the first four characters; i.e., “abcd”. Messages are broadcast only if the last four characters are not “dcba”. Note that the variable "t" controls the length of the timeout period. t = 3 allows one minute of inactivity. t = 30 allows ten minutes, and t = 180 allows an hour. The value inserted below is 360 (2 hours).
+*/
+            conn.onmessage = function(e) {
+                var p = document.createElement("p");
+                p.appendChild(document.createTextNode(e.data));
+                if (e.data.split("").reverse().join("").substring(0,4) != "abcd") {
+                    output.appendChild(p);
+                }   
+            };
+            var t = 360                                 
+            setInterval (function () {
+            	t = t - 1;
+            	if (t > 0) 
+            	{
+                  conn.send("dcba");
+                }
+            }, 20000);
+/* ****************************************************************************************************** */
+            form.addEventListener("submit", function(e){
+                conn.send(input.value);
+                input.value = "";
+                e.preventDefault();
+            });
+        |]
+
+main :: IO ()
+main = do
+    channelMapTVar <- newTVarIO M.empty
+    warp 3000 $ App channelMapTVar

yesod-websockets/chat-with-timeout-control.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables #-}
 import Yesod.Core
 import Yesod.WebSockets
 import qualified Data.Text.Lazy as TL
@@ -10,15 +10,16 @@ import Conduit
 import Data.Monoid ((<>))
 import Control.Concurrent.STM.Lifted
 import Data.Text (Text)
+import UnliftIO.Exception (try, SomeException)
 
 data App = App (TChan Text)
 
-instance Yesod App
-
 mkYesod "App" [parseRoutes|
 / HomeR GET
 |]
 
+instance Yesod App
+
 chatApp :: WebSocketsT Handler ()
 chatApp = do
     sendTextData ("Welcome to the chat server, please enter your name." :: Text)
@@ -28,11 +29,15 @@ chatApp = do
     readChan <- atomically $ do
         writeTChan writeChan $ name <> " has joined the chat"
         dupTChan writeChan
-    race_
+    (e :: Either SomeException ()) <- try $ race_
         (forever $ atomically (readTChan readChan) >>= sendTextData)
         (sourceWS $$ mapM_C (\msg ->
             atomically $ writeTChan writeChan $ name <> ": " <> msg))
 
+    atomically $ case e of
+        Left _ -> writeTChan writeChan $ name <> " has left the chat"
+        Right () -> return ()
+
 getHomeR :: Handler Html
 getHomeR = do
     webSockets chatApp

yesod-websockets/chat.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables #-}
 import Yesod.Core
 import Yesod.WebSockets
 import qualified Data.Text.Lazy as TL
@@ -10,15 +10,16 @@ import Conduit
 import Data.Monoid ((<>))
 import Control.Concurrent.STM.Lifted
 import Data.Text (Text)
+import UnliftIO.Exception (try, SomeException)
 
 data App = App (TChan Text)
 
-instance Yesod App
-
 mkYesod "App" [parseRoutes|
 / HomeR GET
 |]
 
+instance Yesod App
+
 chatApp :: WebSocketsT Handler ()
 chatApp = do
     sendTextData ("Welcome to the chat server, please enter your name." :: Text)
@@ -28,11 +29,15 @@ chatApp = do
     readChan <- atomically $ do
         writeTChan writeChan $ name <> " has joined the chat"
         dupTChan writeChan
-    race_
+    (e :: Either SomeException ()) <- try $ race_
         (forever $ atomically (readTChan readChan) >>= sendTextData)
         (sourceWS $$ mapM_C (\msg ->
             atomically $ writeTChan writeChan $ name <> ": " <> msg))
 
+    atomically $ case e of
+        Left _ -> writeTChan writeChan $ name <> " has left the chat"
+        Right () -> return ()
+
 getHomeR :: Handler Html
 getHomeR = do
     webSockets chatApp

yesod-websockets/yesod-websockets.cabal

@@ -1,6 +1,6 @@
-cabal-version:       1.10
+cabal-version:       >=1.10
 name:                yesod-websockets
-version:             0.3.0.3
+version:             0.3.0.4
 synopsis:            WebSockets support for Yesod
 homepage:            https://github.com/yesodweb/yesod
 license:             MIT

yesod/ChangeLog.md

@@ -1,3 +1,21 @@
+# ChangeLog for yesod
+
+## 1.6.2.1
+
+* Support `template-haskell-2.19.0.0` [#1769](https://github.com/yesodweb/yesod/pull/1769)
+
+## 1.6.2
+
+* aeson 2
+
+## 1.6.1.2
+
+* Fix compatibility with template-haskell 2.17 [#1730](https://github.com/yesodweb/yesod/pull/1730)
+
+## 1.6.1.1
+
+* Allow yesod-form 1.7
+
 ## 1.6.1.0
 
 * `widgetFileReload` and `widgetFileNoReload` now use absolute paths via the new `globFilePackage` Q Exp which can provide absolute templates paths within the project [#1691](https://github.com/yesodweb/yesod/pull/1691)

yesod/Yesod/Default/Config.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternGuards #-}
 module Yesod.Default.Config
@@ -19,12 +20,17 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Yaml
 import Data.Maybe (fromMaybe)
-import qualified Data.HashMap.Strict as M
 import System.Environment (getArgs, getProgName, getEnvironment)
 import System.Exit (exitFailure)
 import Data.Streaming.Network (HostPreference)
 import Data.String (fromString)
 
+#if MIN_VERSION_aeson(2, 0, 0)
+import qualified Data.Aeson.KeyMap as M
+#else
+import qualified Data.HashMap.Strict as M
+#endif
+
 -- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and
 --   Production environments
 data DefaultEnv = Development
@@ -143,7 +149,7 @@ configSettings env0 = ConfigSettings
                 Object obj -> return obj
                 _ -> fail "Expected Object"
         let senv = show env
-            tenv = T.pack senv
+            tenv = fromString senv
         maybe
             (error $ "Could not find environment: " ++ senv)
             return
@@ -237,5 +243,5 @@ withYamlEnvironment fp env f = do
         Left err ->
           fail $ "Invalid YAML file: " ++ show fp ++ " " ++ prettyPrintParseException err
         Right (Object obj)
-            | Just v <- M.lookup (T.pack $ show env) obj -> parseMonad f v
+            | Just v <- M.lookup (fromString $ show env) obj -> parseMonad f v
         _ -> fail $ "Could not find environment: " ++ show env

yesod/Yesod/Default/Config2.hs

@@ -30,7 +30,6 @@ import Data.Yaml.Config
 
 import Data.Semigroup
 import Data.Aeson
-import qualified Data.HashMap.Strict as H
 import System.Environment (getEnvironment)
 import Network.Wai (Application)
 import Network.Wai.Handler.Warp
@@ -43,6 +42,12 @@ import Network.Wai.Logger (clockDateCacher)
 import Yesod.Core.Types (Logger (Logger))
 import System.Log.FastLogger (LoggerSet)
 
+#if MIN_VERSION_aeson(2, 0, 0)
+import qualified Data.Aeson.KeyMap as H
+#else
+import qualified Data.HashMap.Strict as H
+#endif
+
 #ifndef mingw32_HOST_OS
 import System.Posix.Signals (installHandler, sigINT, Handler(Catch))
 #endif

yesod/Yesod/Default/Util.hs

@@ -22,7 +22,7 @@ import Yesod.Core -- purposely using complete import so that Haddock will see ad
 import Control.Monad (when, unless)
 import Conduit
 import System.Directory (doesFileExist, createDirectoryIfMissing)
-import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Syntax hiding (makeRelativeToProject)
 import Text.Lucius (luciusFile, luciusFileReload)
 import Text.Julius (juliusFile, juliusFileReload)
 import Text.Cassius (cassiusFile, cassiusFileReload)
@@ -113,7 +113,11 @@ combine func file isReload tls = do
             , show file
             , ", but no templates were found."
             ]
+#if MIN_VERSION_template_haskell(2,17,0)
+        exps -> return $ DoE Nothing $ map NoBindS exps
+#else
         exps -> return $ DoE $ map NoBindS exps
+#endif
   where
     qmexps :: Q [Maybe Exp]
     qmexps = mapM go tls

yesod/yesod.cabal

@@ -1,5 +1,5 @@
 name:            yesod
-version:         1.6.1.0
+version:         1.6.2.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -38,7 +38,7 @@ library
                    , warp                      >= 1.3
                    , yaml                      >= 0.8.17
                    , yesod-core                >= 1.6      && < 1.7
-                   , yesod-form                >= 1.6      && < 1.7
+                   , yesod-form                >= 1.6      && < 1.8
                    , yesod-persistent          >= 1.6      && < 1.7
 
     exposed-modules: Yesod