.azure/azure-linux-template.yml

@@ -0,0 +1,25 @@
+jobs:
+- job: ${{ parameters.name }}
+  timeoutInMinutes: 180
+  pool:
+    vmImage: ${{ parameters.vmImage }}
+  strategy:
+    matrix:
+      GHC 8.2:
+        ARGS: "--resolver lts-11"
+      GHC 8.4:
+        ARGS: "--resolver lts-12"
+      GHC 8.6:
+        ARGS: "--resolver lts-14"
+      GHC 8.8:
+        ARGS: "--resolver lts-15"
+  steps:
+  - script: |
+      export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
+      export PATH=$HOME/.local/bin:$PATH
+      mkdir -p ~/.local/bin
+      curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
+      stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
+    env:
+      OS_NAME: ${{ parameters.os }}
+    displayName: 'Build and test'

.azure/azure-osx-template.yml

@@ -0,0 +1,25 @@
+jobs:
+- job: ${{ parameters.name }}
+  timeoutInMinutes: 120
+  pool:
+    vmImage: ${{ parameters.vmImage }}
+  strategy:
+    matrix:
+      GHC 8.2:
+        ARGS: "--resolver lts-11"
+      GHC 8.4:
+        ARGS: "--resolver lts-12"
+      GHC 8.6:
+        ARGS: "--resolver lts-14"
+      GHC 8.8:
+        ARGS: "--resolver lts-15"
+  steps:
+  - script: |
+      export PATH=$HOME/.local/bin:$PATH
+      export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
+      mkdir -p ~/.local/bin
+      curl -skL https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;
+      stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
+    env:
+      OS_NAME: ${{ parameters.os }}
+    displayName: 'Build and test'

.azure/azure-pipelines.yml

@@ -0,0 +1,30 @@
+# This is the complex Azure configuration, which is intended for use
+# on open source libraries which need compatibility across multiple GHC
+# versions, must work with cabal-install, and should be
+# cross-platform. For more information and other options, see:
+#
+# https://docs.haskellstack.org/en/stable/azure_ci/
+#
+# Copy these contents into the root directory of your Github project in a file
+# named azure-pipelines.yml
+#
+# For better organization, you split various jobs into seprate parts
+# and each of them are controlled via individual file.
+jobs:
+- template: azure-linux-template.yml
+  parameters:
+    name: Linux
+    vmImage: ubuntu-latest
+    os: linux
+
+- template: azure-osx-template.yml
+  parameters:
+    name: macOS
+    vmImage: macOS-latest
+    os: osx
+
+- template: azure-windows-template.yml
+  parameters:
+   name: Windows
+   vmImage: windows-latest
+   os: windows

.azure/azure-windows-template.yml

@@ -0,0 +1,22 @@
+jobs:
+- job: ${{ parameters.name }}
+  timeoutInMinutes: 120
+  pool:
+    vmImage: ${{ parameters.vmImage }}
+  strategy:
+    matrix:
+      GHC 8.2:
+        ARGS: "--resolver lts-11"
+      GHC 8.4:
+        ARGS: "--resolver lts-12"
+      GHC 8.6:
+        ARGS: "--resolver lts-14"
+  steps:
+  - bash: |
+      export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
+      curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip
+      unzip -o /usr/bin/stack.zip -d /usr/bin/
+      stack $ARGS test --bench --no-run-benchmarks
+    env:
+      OS_NAME: ${{ parameters.os }}
+    displayName: 'Build and test'

.github/workflows/tests.yml

@@ -1,56 +0,0 @@
-name: Tests
-
-on:
-    pull_request:
-    push:
-        branches:
-        - master
-
-jobs:
-  build:
-    name: CI
-    runs-on: ${{ matrix.os }}
-    strategy:
-      fail-fast: false
-      matrix:
-        os: [ubuntu-latest, macos-latest, windows-latest]
-        args:
-        #- "--resolver nightly"
-        - "--resolver nightly-2022-02-11"
-        - "--resolver lts-18"
-        - "--resolver lts-16"
-        - "--resolver lts-14"
-        - "--resolver lts-12"
-        - "--resolver lts-11"
-        # Bugs in GHC make it crash too often to be worth running
-        exclude:
-          - os: windows-latest
-            args: "--resolver nightly"
-          - os: macos-latest
-            args: "--resolver lts-16"
-          - os: macos-latest
-            args: "--resolver lts-14"
-          - os: macos-latest
-            args: "--resolver lts-12"
-          - os: macos-latest
-            args: "--resolver lts-11"
-
-    steps:
-      - name: Clone project
-        uses: actions/checkout@v2
-
-# Getting weird OS X errors...
-#      - name: Cache dependencies
-#        uses: actions/cache@v1
-#        with:
-#          path: ~/.stack
-#          key: ${{ runner.os }}-${{ matrix.resolver }}-${{ hashFiles('stack.yaml') }}
-#          restore-keys: |
-#            ${{ runner.os }}-${{ matrix.resolver }}-
-
-      - name: Build and run tests
-        shell: bash
-        run: |
-            set -ex
-            stack --version
-            stack test --fast --no-terminal ${{ matrix.args }}

.gitignore

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

README.md

@@ -1,4 +1,4 @@
-![Tests](https://github.com/yesodweb/yesod/workflows/Tests/badge.svg)
+[![Build Status](https://dev.azure.com/yesodweb/yesod/_apis/build/status/yesodweb.yesod?branchName=master)](https://dev.azure.com/yesodweb/yesod/_build/latest?definitionId=3&branchName=master)
 
 # Yesod Web Framework
 

cabal.project

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

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-form for
+-- master must be able to render form messages, as we use yesod-forms for
 -- processing user input.
 class (RenderMessage master FormMessage, Yesod master) => YesodWiki master where
     -- | Write protection. By default, no protection.

stack.yaml

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

stack.yaml.lock

@@ -3,17 +3,10 @@
 # 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:
-    sha256: 694573e96dca34db5636edb1fe6c96bb233ca0f9fb96c1ead1671cdfa9bd73e9
+    size: 491372
-    size: 585603
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/5.yaml
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/3.yaml
+    sha256: 1b549cfff328040c382a70a84a2087aac8dab6d778bf92f32a93a771a1980dfc
-  original: lts-18.3
+  original: lts-15.5

yesod-auth-oauth/ChangeLog.md

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

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

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

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

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

yesod-auth/ChangeLog.md

@@ -1,37 +1,5 @@
 # ChangeLog for yesod-auth
 
-## 1.6.11.2
-
-* Add support for aeson 2.2 [#1820](https://github.com/yesodweb/yesod/pull/1820)
-
-## 1.6.11.1
-
-* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
-
-## 1.6.11
-
-* Add support for aeson 2
-
-## 1.6.10.5
-
-* Fix German translations of AuthMessage [#1741](https://github.com/yesodweb/yesod/pull/1741)
-
-## 1.6.10.4
-
-* Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737)
-
-## 1.6.10.3
-
-* Relax bounds for yesod-form 1.7
-
-## 1.6.10.2
-
-* Relax bounds for persistent 2.12
-
-## 1.6.10.1
-
-* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)
-
 ## 1.6.10
 
 * Updated `AuthMessage` data type in `Yesod.Auth.Message` to accommodate registration flow where password is supplied initially: deprecated `AddressVerified` and split into `EmailVerifiedChangePass` and `EmailVerified`

yesod-auth/README.md

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

yesod-auth/Yesod/Auth.hs

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

yesod-auth/Yesod/Auth/Dummy.hs

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

yesod-auth/Yesod/Auth/Email.hs

@@ -117,30 +117,28 @@ module Yesod.Auth.Email
     , defaultRegisterHelper
     ) where
 
-import           Control.Applicative           ((<$>), (<*>))
-import qualified Crypto.Hash                   as H
-import qualified Crypto.Nonce                  as Nonce
-import           Data.Aeson.Types              (Parser, Result (..), parseMaybe,
-                                                withObject, (.:?))
-import           Data.ByteArray                (convert)
-import           Data.ByteString.Base16        as B16
-import           Data.Maybe                    (isJust)
-import           Data.Text                     (Text)
-import qualified Data.Text                     as T
-import qualified Data.Text                     as TS
-import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8)
-import qualified Data.Text.Encoding            as TE
-import           Data.Text.Encoding.Error      (lenientDecode)
-import           Data.Time                     (addUTCTime, getCurrentTime)
-import           Safe                          (readMay)
-import           System.IO.Unsafe              (unsafePerformIO)
-import qualified Text.Email.Validate
 import           Yesod.Auth
-import qualified Yesod.Auth.Message            as Msg
+import qualified Yesod.Auth.Message       as Msg
-import qualified Yesod.Auth.Util.PasswordStore as PS
 import           Yesod.Core
-import           Yesod.Core.Types              (TypedContent (TypedContent))
 import           Yesod.Form
+import qualified Yesod.Auth.Util.PasswordStore as PS
+import           Control.Applicative      ((<$>), (<*>))
+import qualified Crypto.Hash              as H
+import qualified Crypto.Nonce             as Nonce
+import           Data.ByteString.Base16   as B16
+import           Data.Text                (Text)
+import qualified Data.Text                as TS
+import qualified Data.Text                as T
+import           Data.Text.Encoding       (decodeUtf8With, encodeUtf8)
+import qualified Data.Text.Encoding       as TE
+import           Data.Text.Encoding.Error (lenientDecode)
+import           Data.Time                (addUTCTime, getCurrentTime)
+import           Safe                     (readMay)
+import           System.IO.Unsafe         (unsafePerformIO)
+import qualified Text.Email.Validate
+import           Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
+import           Data.Maybe (isJust)
+import Data.ByteArray (convert)
 
 loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
 loginR = PluginR "email" ["login"]
@@ -242,7 +240,7 @@ class ( YesodAuth site
     --
     -- @since 1.4.20
     hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
-    hashAndSaltPassword password = liftIO $ saltPass password
+    hashAndSaltPassword = liftIO . saltPass
 
     -- | Verify a password matches the stored password for the given account.
     --
@@ -434,14 +432,13 @@ authEmail :: (YesodAuthEmail m) => AuthPlugin m
 authEmail =
     AuthPlugin "email" dispatch emailLoginHandler
   where
-    dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent
     dispatch "GET" ["register"] = getRegisterR >>= sendResponse
     dispatch "POST" ["register"] = postRegisterR >>= sendResponse
     dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse
     dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse
     dispatch "GET" ["verify", eid, verkey] =
         case fromPathPiece eid of
-            Nothing   -> notFound
+            Nothing -> notFound
             Just eid' -> getVerifyR eid' verkey False >>= sendResponse
     dispatch "GET" ["verify", eid, verkey, hasSetPass] =
         case fromPathPiece eid of
@@ -488,13 +485,13 @@ defaultEmailLoginHandler toParent = do
         let userRes = UserLoginForm Control.Applicative.<$> emailRes
                                     Control.Applicative.<*> passwordRes
         let widget = do
-              [whamlet|
+            [whamlet|
-                  #{extra}
+                #{extra}
-                  <div>
+                <div>
-                      ^{fvInput emailView}
+                    ^{fvInput emailView}
-                  <div>
+                <div>
-                      ^{fvInput passwordView}
+                    ^{fvInput passwordView}
-              |]
+            |]
 
         return (userRes, widget)
     emailSettings emailMsg = do
@@ -548,11 +545,11 @@ defaultRegisterHandler = do
 
             let userRes = UserForm <$> emailRes
             let widget = do
-                  [whamlet|
+                [whamlet|
-                      #{extra}
+                    #{extra}
-                      ^{fvLabel emailView}
+                    ^{fvLabel emailView}
-                      ^{fvInput emailView}
+                    ^{fvInput emailView}
-                  |]
+                |]
 
             return (userRes, widget)
 
@@ -579,7 +576,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                  _ -> do
                      (creds :: Result Value) <- parseCheckJsonBody
                      return $ case creds of
-                                  Error _     -> Nothing
+                                  Error _ -> Nothing
                                   Success val -> parseMaybe parseRegister val
 
     let eidentifier = case creds of
@@ -592,7 +589,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
 
     let mpass = case (forgotPassword, creds) of
                     (False, Just (_, mp)) -> mp
-                    _                     -> Nothing
+                    _ -> Nothing
 
     case eidentifier of
       Left failMsg -> loginErrorMessageI dest failMsg
@@ -623,7 +620,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
                     then sendConfirmationEmail creds
                     else case emailPreviouslyRegisteredResponse identifier of
                       Just response -> response
-                      Nothing       -> sendConfirmationEmail creds
+                      Nothing -> sendConfirmationEmail creds
               where sendConfirmationEmail (lid, _, verKey, email) = do
                       render <- getUrlRender
                       tp <- getRouteToParent
@@ -662,11 +659,11 @@ defaultForgotPasswordHandler = do
 
         let forgotPasswordRes = ForgotPasswordForm <$> emailRes
         let widget = do
-              [whamlet|
+            [whamlet|
-                  #{extra}
+                #{extra}
-                  ^{fvLabel emailView}
+                ^{fvLabel emailView}
-                  ^{fvInput emailView}
+                ^{fvInput emailView}
-              |]
+            |]
         return (forgotPasswordRes, widget)
 
     emailSettings =
@@ -742,7 +739,7 @@ postLoginR = do
                      _ -> do
                        (creds :: Result Value) <- parseCheckJsonBody
                        case creds of
-                         Error _     -> return Nothing
+                         Error _ -> return Nothing
                          Success val -> return $ parseMaybe parseCreds val
 
     case midentifier of
@@ -782,8 +779,8 @@ getPasswordR = do
     maid <- maybeAuthId
     case maid of
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-        Just aid -> do
+        Just _ -> do
-            needOld <- needOldPassword aid
+            needOld <- maybe (return True) needOldPassword maid
             setPasswordHandler needOld
 
 -- | Default implementation of 'setPasswordHandler'.
@@ -811,29 +808,29 @@ defaultSetPasswordHandler needOld = do
 
         let passwordFormRes = PasswordForm <$> currentPasswordRes <*> newPasswordRes <*> confirmPasswordRes
         let widget = do
-              [whamlet|
+            [whamlet|
-                  #{extra}
+                #{extra}
-                  <table>
+                <table>
-                      $if needOld
+                    $if needOld
-                          <tr>
+                        <tr>
-                              <th>
+                            <th>
-                                  ^{fvLabel currentPasswordView}
+                                ^{fvLabel currentPasswordView}
-                              <td>
+                            <td>
-                                  ^{fvInput currentPasswordView}
+                                ^{fvInput currentPasswordView}
-                      <tr>
+                    <tr>
-                          <th>
+                        <th>
-                              ^{fvLabel newPasswordView}
+                            ^{fvLabel newPasswordView}
-                          <td>
+                        <td>
-                              ^{fvInput newPasswordView}
+                            ^{fvInput newPasswordView}
-                      <tr>
+                    <tr>
-                          <th>
+                        <th>
-                              ^{fvLabel confirmPasswordView}
+                            ^{fvLabel confirmPasswordView}
-                          <td>
+                        <td>
-                              ^{fvInput confirmPasswordView}
+                            ^{fvInput confirmPasswordView}
-                      <tr>
+                    <tr>
-                          <td colspan="2">
+                        <td colspan="2">
-                              <input type=submit value=_{Msg.SetPassTitle}>
+                            <input type=submit value=_{Msg.SetPassTitle}>
-              |]
+            |]
 
         return (passwordFormRes, widget)
     currentPasswordSettings =
@@ -873,7 +870,7 @@ postPasswordR = do
     maid <- maybeAuthId
     (creds :: Result Value) <- parseCheckJsonBody
     let jcreds = case creds of
-                   Error _     -> Nothing
+                   Error _ -> Nothing
                    Success val -> parseMaybe parsePassword val
     let doJsonParsing = isJust jcreds
     case maid of
@@ -885,7 +882,7 @@ postPasswordR = do
                 res <- runInputPostResult $ ireq textField "current"
                 let fcurrent = case res of
                                  FormSuccess currentPass -> Just currentPass
-                                 _                       -> Nothing
+                                 _ -> Nothing
                 let current = if doJsonParsing
                               then getThird jcreds
                               else fcurrent
@@ -904,9 +901,9 @@ postPasswordR = do
   where
     msgOk = Msg.PassUpdated
     getThird (Just (_,_,t)) = t
-    getThird Nothing        = Nothing
+    getThird Nothing = Nothing
     getNewConfirm (Just (a,b,_)) = Just (a,b)
-    getNewConfirm _              = Nothing
+    getNewConfirm _ = Nothing
     confirmPassword aid tm jcreds = do
         res <- runInputPostResult $ (,)
             <$> ireq textField "new"
@@ -915,7 +912,7 @@ postPasswordR = do
                     then getNewConfirm jcreds
                     else case res of
                            FormSuccess res' -> Just res'
-                           _                -> Nothing
+                           _ -> Nothing
         case creds of
           Nothing -> loginErrorMessageI setpassR Msg.PassMismatch
           Just (new, confirm) ->

yesod-auth/Yesod/Auth/GoogleEmail2.hs

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

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

yesod-auth/yesod-auth.cabal

@@ -1,6 +1,5 @@
-cabal-version:   >=1.10
 name:            yesod-auth
-version:         1.6.11.2
+version:         1.6.10
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -8,6 +7,7 @@ maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        Authentication for Yesod.
 category:        Web, Yesod
 stability:       Stable
+cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-auth>
@@ -20,10 +20,8 @@ flag network-uri
   default: True
 
 library
-    default-language: Haskell2010
     build-depends:   base                    >= 4.10      && < 5
                    , aeson                   >= 0.7
-                   , attoparsec-aeson        >= 2.1
                    , authenticate            >= 1.3.4
                    , base16-bytestring
                    , base64-bytestring
@@ -45,7 +43,7 @@ library
                    , http-types
                    , memory
                    , nonce                   >= 1.0.2     && < 1.1
-                   , persistent              >= 2.8
+                   , persistent              >= 2.8       && < 2.11
                    , random                  >= 1.0.0.2
                    , safe
                    , shakespeare
@@ -58,7 +56,7 @@ library
                    , unordered-containers
                    , wai                     >= 1.4
                    , yesod-core              >= 1.6       && < 1.7
-                   , yesod-form              >= 1.6       && < 1.8
+                   , yesod-form              >= 1.6       && < 1.7
                    , yesod-persistent        >= 1.6
 
     if flag(network-uri)

yesod-bin/AddHandler.hs

@@ -9,18 +9,13 @@ import Data.List  (isPrefixOf, isSuffixOf, stripPrefix)
 import Data.Maybe (fromMaybe, listToMaybe)
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
-#if MIN_VERSION_Cabal(3, 7, 0)
+#if MIN_VERSION_Cabal(2, 2, 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)
@@ -67,18 +62,18 @@ addHandlerInteractive :: IO ()
 addHandlerInteractive = do
     cabal <- getCabal
     let routeInput = do
-          putStr "Name of route (without trailing R): "
+        putStr "Name of route (without trailing R): "
-          hFlush stdout
+        hFlush stdout
-          name <- getLine
+        name <- getLine
-          checked <- checkRoute name cabal
+        checked <- checkRoute name cabal
-          case checked of
+        case checked of
-              Left err@EmptyRoute -> (error . show) err
+            Left err@EmptyRoute -> (error . show) err
-              Left err@RouteCaseError -> print err >> routeInput
+            Left err@RouteCaseError -> print err >> routeInput
-              Left err@(RouteExists _) -> do
+            Left err@(RouteExists _) -> do
-                print err
+              print err
-                putStrLn "Try another name or leave blank to exit"
+              putStrLn "Try another name or leave blank to exit"
-                routeInput
+              routeInput
-              Right p -> return p
+            Right p -> return p
 
     routePair <- routeInput
     putStr "Enter route pattern (ex: /entry/#EntryId): "
@@ -89,22 +84,13 @@ addHandlerInteractive = do
     methods <- getLine
     addHandlerFiles cabal routePair pattern methods
 
-getRoutesFilePath :: IO FilePath
-getRoutesFilePath = do
-    let oldPath = "config/routes"
-    oldExists <- doesFileExist oldPath
-    pure $ if oldExists
-        then oldPath
-        else "config/routes.yesodroutes"
-
 addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO ()
 addHandlerFiles cabal (name, handlerFile) pattern methods = do
     src <- getSrcDir cabal
     let applicationFile = concat [src, "/Application.hs"]
     modify applicationFile $ fixApp name
     modify cabal $ fixCabal name
-    routesPath <- getRoutesFilePath
+    modify "config/routes" $ fixRoutes name pattern methods
-    modify routesPath $ fixRoutes name pattern methods
     writeFile handlerFile $ mkHandler name pattern methods
     specExists <- doesFileExist specFile
     unless specExists $
@@ -252,8 +238,4 @@ getSrcDir cabal = do
 #endif
     let buildInfo = allBuildInfo pd
         srcDirs = concatMap hsSourceDirs buildInfo
-#if MIN_VERSION_Cabal(3, 6, 0)
-    return $ maybe "." getSymbolicPath $ listToMaybe srcDirs
-#else
     return $ fromMaybe "." $ listToMaybe srcDirs
-#endif

yesod-bin/ChangeLog.md

@@ -1,29 +1,3 @@
-# ChangeLog for yesod-bin
-
-## 1.6.2.2
-
-* Support Cabal 3.8 [#1769](https://github.com/yesodweb/yesod/pull/1769)
-
-## 1.6.2.1
-
-* Support Cabal 3.6 [#1754](https://github.com/yesodweb/yesod/pull/1754)
-
-## 1.6.2
-
-* aeson 2.0
-
-## 1.6.1
-
-Added command line options `cert` and `key` to allow TLS certificate and key files to be passed to `yesod devel` [#1717](https://github.com/yesodweb/yesod/pull/1717)
-
-## 1.6.0.6
-
-Fix the `add-handler` subcommand to support both the old default routes filename (`routes`) and the new one (`routes.yesodroutes`) [#1688](https://github.com/yesodweb/yesod/pull/1688)
-
-## 1.6.0.5
-
-* Use process groups to ensure GHC is killed on Ctrl-C [#1683](https://github.com/yesodweb/yesod/pull/1683)
-
 ## 1.6.0.4
 
 * Support Cabal 3.0

yesod-bin/Devel.hs

@@ -28,9 +28,6 @@ import           Data.String                           (fromString)
 import           Data.Time                             (getCurrentTime)
 import qualified Distribution.Package                  as D
 import qualified Distribution.PackageDescription       as D
-#if MIN_VERSION_Cabal(3,8,0)
-import qualified Distribution.Simple.PackageDescription as D
-#endif
 #if MIN_VERSION_Cabal(2, 2, 0)
 import qualified Distribution.PackageDescription.Parsec as D
 #else
@@ -59,7 +56,7 @@ import           Network.Wai                           (requestHeaderHost,
                                                         responseLBS)
 import           Network.Wai.Handler.Warp              (defaultSettings, runSettings,
                                                         setPort, setHost)
-import           Network.Wai.Handler.WarpTLS           (runTLS, tlsSettings,
+import           Network.Wai.Handler.WarpTLS           (runTLS,
                                                         tlsSettingsMemory)
 import           Network.Wai.Parse                     (parseHttpAccept)
 import           Say
@@ -129,7 +126,6 @@ data DevelOpts = DevelOpts
       , proxyTimeout    :: Int
       , useReverseProxy :: Bool
       , develHost       :: Maybe String
-      , cert            :: Maybe (FilePath, FilePath)
       } deriving (Show, Eq)
 
 -- | Run a reverse proxy from the develPort and develTlsPort ports to
@@ -174,12 +170,10 @@ reverseProxy opts appPortVar = do
                 manager
         defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings
         runProxyTls port app = do
-          let certDef = $(embedFile "certificate.pem")
+          let cert = $(embedFile "certificate.pem")
-              keyDef = $(embedFile "key.pem")
+              key = $(embedFile "key.pem")
-              theSettings = case cert opts of
+              tlsSettings = tlsSettingsMemory cert key
-                Nothing -> tlsSettingsMemory certDef keyDef
+          runTLS tlsSettings (setPort port defaultSettings') $ \req send -> do
-                Just (c,k) -> tlsSettings c k
-          runTLS theSettings (setPort port defaultSettings') $ \req send -> do
             let req' = req
                     { requestHeaders
                         = ("X-Forwarded-Proto", "https")
@@ -351,8 +345,7 @@ devel opts passThroughArgs = do
         myPath <- getExecutablePath
         let procConfig = setStdout createSource
                        $ setStderr createSource
-                       $ setCreateGroup True -- because need when yesod-bin killed and kill child ghc
+                       $ setDelegateCtlc True $ proc "stack" $
-                       $ proc "stack" $
                 [ "build"
                 , "--fast"
                 , "--file-watch"

yesod-bin/Keter.hs

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

yesod-bin/README.md

@@ -83,7 +83,6 @@ Now some weird notes:
   `yesod devel` also writes to a file
   `yesod-devel/devel-terminate`. Your devel script should respect this
   file and shutdown whenever it exists.
-  (It may be fixed in 1.6.0.5.)
 * If your .cabal file defines them, `yesod devel` will tell Stack to
   build with the flags `dev` and `library-only`. You can use this to
   speed up compile times (biggest win: skip building executables, thus

yesod-bin/main.hs

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

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.6.2.2
+version:         1.6.0.4
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -8,7 +8,7 @@ synopsis:        The yesod helper executable.
 description:     See README.md for more information
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.10
+cabal-version:   >= 1.6
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 
@@ -19,7 +19,6 @@ extra-source-files:
   *.pem
 
 executable             yesod
-    default-language: Haskell2010
     if os(windows)
         cpp-options:     -DWINDOWS
     if os(openbsd)
@@ -35,7 +34,7 @@ executable             yesod
                      , directory          >= 1.2.1
                      , file-embed
                      , filepath           >= 1.1
-                     , fsnotify
+                     , fsnotify           >= 0.0          && < 0.4
                      , http-client        >= 0.4.7
                      , http-client-tls
                      , http-reverse-proxy >= 0.4
@@ -61,7 +60,6 @@ executable             yesod
                      , warp-tls           >= 3.0.1
                      , yaml               >= 0.8          && < 0.12
                      , zlib               >= 0.5
-                     , aeson
 
     ghc-options:       -Wall -threaded -rtsopts
     main-is:           main.hs

yesod-core/ChangeLog.md

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

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

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

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

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

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

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

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

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

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

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

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

@@ -9,7 +9,6 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TemplateHaskell            #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -245,7 +244,6 @@ import           Text.Blaze.Html               (preEscapedToHtml, toHtml)
 import qualified Data.IORef                    as I
 import           Data.Maybe                    (listToMaybe, mapMaybe)
 import           Data.Typeable                 (Typeable)
-import           Data.Kind                     (Type)
 import           Web.PathPieces                (PathPiece(..))
 import           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
@@ -262,7 +260,7 @@ import qualified Data.Word8 as W8
 import qualified Data.Foldable as Fold
 import           Control.Monad.Logger (MonadLogger, logWarnS)
 
-type HandlerT site (m :: Type -> Type) = HandlerFor site
+type HandlerT site (m :: * -> *) = HandlerFor site
 {-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
 
 get :: MonadHandler m => m GHState
@@ -371,10 +369,10 @@ getPostParams = do
 getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
 getCurrentRoute = rheRoute <$> askHandlerEnv
 
--- | Returns a function that runs 'HandlerFor' actions inside @IO@.
+-- | Returns a function that runs 'HandlerT' actions inside @IO@.
 --
--- Sometimes you want to run an inner 'HandlerFor' action outside
+-- Sometimes you want to run an inner 'HandlerT' action outside
--- the control flow of an HTTP request (on the outer 'HandlerFor'
+-- the control flow of an HTTP request (on the outer 'HandlerT'
 -- action).  For example, you may want to spawn a new thread:
 --
 -- @
@@ -382,30 +380,30 @@ getCurrentRoute = rheRoute <$> askHandlerEnv
 -- getFooR = do
 --   runInnerHandler <- handlerToIO
 --   liftIO $ forkIO $ runInnerHandler $ do
---     /Code here runs inside HandlerFor but on a new thread./
+--     /Code here runs inside GHandler but on a new thread./
---     /This is the inner HandlerFor./
+--     /This is the inner GHandler./
 --     ...
 --   /Code here runs inside the request's control flow./
---   /This is the outer HandlerFor./
+--   /This is the outer GHandler./
 --   ...
 -- @
 --
 -- Another use case for this function is creating a stream of
--- server-sent events using 'HandlerFor' actions (see
+-- server-sent events using 'GHandler' actions (see
 -- @yesod-eventsource@).
 --
--- Most of the environment from the outer 'HandlerFor' is preserved
+-- Most of the environment from the outer 'GHandler' is preserved
--- on the inner 'HandlerFor', however:
+-- on the inner 'GHandler', however:
 --
 --  * The request body is cleared (otherwise it would be very
 --  difficult to prevent huge memory leaks).
 --
---  * The cache is cleared (see 'cached').
+--  * The cache is cleared (see 'CacheKey').
 --
--- Changes to the response made inside the inner 'HandlerFor' are
+-- Changes to the response made inside the inner 'GHandler' are
 -- ignored (e.g., session variables, cookies, response headers).
--- This allows the inner 'HandlerFor' to outlive the outer
+-- This allows the inner 'GHandler' to outlive the outer
--- 'HandlerFor' (e.g., on the @forkIO@ example above, a response
+-- 'GHandler' (e.g., on the @forkIO@ example above, a response
 -- may be sent to the client without killing the new thread).
 handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a)
 handlerToIO =
@@ -430,7 +428,7 @@ handlerToIO =
     -- xx From this point onwards, no references to oldHandlerData xx
     liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())
 
-    -- Return HandlerFor running function.
+    -- Return GHandler running function.
     return $ \(HandlerFor f) ->
       liftIO $
       runResourceT $ withInternalState $ \resState -> do
@@ -1227,10 +1225,10 @@ cacheBySet key value = do
 -- Languages are determined based on the following (in descending order
 -- of preference):
 --
--- * The _LANG get parameter.
---
 -- * The _LANG user session variable.
 --
+-- * The _LANG get parameter.
+--
 -- * The _LANG cookie.
 --
 -- * Accept-Language HTTP header.
@@ -1239,12 +1237,11 @@ cacheBySet key value = do
 -- If a matching language is not found the default language will be used.
 --
 -- This is handled by parseWaiRequest (not exposed).
---
--- __NOTE__: Before version @1.6.19.0@, this function prioritized the session
--- variable above all other sources.
---
 languages :: MonadHandler m => m [Text]
-languages = reqLangs <$> getRequest
+languages = do
+    mlang <- lookupSession langKey
+    langs <- reqLangs <$> getRequest
+    return $ maybe id (:) mlang langs
 
 lookup' :: Eq a => a -> [(a, b)] -> [b]
 lookup' a = map snd . filter (\x -> a == fst x)
@@ -1466,8 +1463,8 @@ respond ct = return . TypedContent ct . toContent
 
 -- | Use a @Source@ for the response body.
 --
--- Note that, for ease of use, the underlying monad is a @HandlerFor@. This
+-- Note that, for ease of use, the underlying monad is a @HandlerT@. This
--- implies that you can run any @HandlerFor@ action. However, since a streaming
+-- implies that you can run any @HandlerT@ action. However, since a streaming
 -- response occurs after the response headers have already been sent, some
 -- actions make no sense here. For example: short-circuit responses, setting
 -- headers, changing status codes, etc.
@@ -1478,8 +1475,8 @@ respondSource :: ContentType
               -> HandlerFor site TypedContent
 respondSource ctype src = HandlerFor $ \hd ->
     -- Note that this implementation relies on the fact that the ResourceT
-    -- environment provided by the server is the same one used in HandlerFor.
+    -- environment provided by the server is the same one used in HandlerT.
-    -- This is a safe assumption assuming the HandlerFor is run correctly.
+    -- This is a safe assumption assuming the HandlerT is run correctly.
     return $ TypedContent ctype $ ContentSource
            $ transPipe (lift . flip unHandlerFor hd) src
 

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

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

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

@@ -1,48 +1,10 @@
-{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
+module Yesod.Core.Internal.TH where
-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
@@ -60,7 +22,6 @@ import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
 
 import Yesod.Routes.TH
 import Yesod.Routes.Parse
-import Yesod.Core.Content (ToTypedContent (..))
 import Yesod.Core.Types
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
@@ -74,17 +35,7 @@ import Yesod.Core.Internal.Run
 mkYesod :: String -- ^ name of the argument datatype
         -> [ResourceTree String]
         -> Q [Dec]
-mkYesod = mkYesodOpts defaultOpts
+mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return
-
--- | `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. 
@@ -97,30 +48,15 @@ mkYesodWith :: [[String]] -- ^ list of contexts
             -> Q [Dec]
 mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return
 
-
 -- | Sometimes, you will want to declare your routes in one file and define
 -- your handlers elsewhere. For example, this is the only way to break up a
 -- monolithic file into smaller parts. Use this function, paired with
 -- 'mkYesodDispatch', to do just that.
 mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodData = mkYesodDataOpts defaultOpts
+mkYesodData name resS = fst <$> mkYesodWithParser name False return resS
-
--- | `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 = mkYesodSubDataOpts defaultOpts
+mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS
-
--- |
---
--- @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
@@ -128,22 +64,11 @@ mkYesodWithParser :: String                    -- ^ foundation type
                   -> (Exp -> Q Exp)            -- ^ unwrap handler
                   -> [ResourceTree String]
                   -> Q([Dec],[Dec])
-mkYesodWithParser = mkYesodWithParserOpts defaultOpts
+mkYesodWithParser name isSub f resS = do
-
--- | 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
-    mkYesodGeneralOpts opts cxt name' rest isSub f resS
+    mkYesodGeneral cxt name' rest isSub f resS
 
     where
         parseName = do
@@ -175,28 +100,19 @@ mkYesodWithParserOpts opts name isSub f resS = do
         parseContexts = 
             sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
 
-
 -- | See 'mkYesodData'.
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodDispatch = mkYesodDispatchOpts defaultOpts
+mkYesodDispatch name = fmap snd . mkYesodWithParser name False return
-
--- | 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
@@ -204,20 +120,7 @@ mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in Ren
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral = mkYesodGeneralOpts defaultOpts
+mkYesodGeneral appCxt' namestr mtys isSub f resS = do
-
--- |
---
--- @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'
@@ -238,14 +141,11 @@ mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
     let name = mkName namestr
     -- Generate as many variable names as the arity indicates
     vns <- replicateM (arity - length mtys) $ newName "t"
-    -- types that you apply to get a concrete site name
-    let argtypes = fmap nameToType mtys ++ fmap VarT vns
-    -- typevars that should appear in synonym head
-    let argvars = (fmap mkName . filter isTvar) mtys ++ vns
         -- Base type (site type with variables)
-    let site = foldl' AppT (ConT name) argtypes
+    let argtypes = fmap nameToType mtys ++ fmap VarT vns
+        site = foldl' AppT (ConT name) argtypes
         res = map (fmap (parseType . dropBracket)) resS
-    renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res
+    renderRouteDec <- mkRenderRouteInstance appCxt site res
     routeAttrsDec  <- mkRouteAttrsInstance appCxt site res
     dispatchDec    <- mkDispatchInstance site appCxt f res
     parseRoute <- mkParseRouteInstance appCxt site res
@@ -260,15 +160,22 @@ mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
             , renderRouteDec
             , [routeAttrsDec]
             , resourcesDec
-            , if isSub then [] else masterTypeSyns argvars site
+            , if isSub then [] else masterTypeSyns vns site
             ]
     return (dataDec, dispatchDec)
 
-
+mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
-mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
+mkMDS f rh = MkDispatchSettings
-mkMDS f rh sd = MkDispatchSettings
     { mdsRunHandler = rh
-    , mdsSubDispatcher = sd
+    , mdsSubDispatcher =
+        [|\parentRunner getSub toParent env -> yesodSubDispatch
+                                 YesodSubRunnerEnv
+                                    { ysreParentRunner = parentRunner
+                                    , ysreGetSub = getSub
+                                    , ysreToParentRoute = toParent
+                                    , ysreParentEnv = env
+                                    }
+                              |]
     , mdsGetPathInfo = [|W.pathInfo|]
     , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
     , mdsMethod = [|W.requestMethod|]
@@ -289,35 +196,15 @@ mkDispatchInstance :: Type                      -- ^ The master site type
                    -> [ResourceTree c]          -- ^ The resource
                    -> DecsQ
 mkDispatchInstance master cxt f res = do
-    clause' <- 
+    clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res
-        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' <- 
+    clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
-        mkDispatchClause
-            (mkMDS 
-                return 
-                [|subHelper|] 
-                [|subTopDispatch|]) 
-        res
     inner <- newName "inner"
     let innerFun = FunD inner [clause']
     helper <- newName "helper"
@@ -329,26 +216,5 @@ mkYesodSubDispatch res = do
                 ]
     return $ LetE [fun] (VarE helper)
 
-
-subTopDispatch :: 
-    (YesodSubDispatch sub master) =>
-        (forall content. ToTypedContent content =>
-            SubHandlerFor child master content ->
-            YesodSubRunnerEnv child master ->
-            Maybe (Route child) ->
-            W.Application
-        ) ->
-        (mid -> sub) ->
-        (Route sub -> Route mid) ->
-        YesodSubRunnerEnv mid master ->
-        W.Application
-subTopDispatch _ getSub toParent env = yesodSubDispatch
-            (YesodSubRunnerEnv
-            { ysreParentRunner = ysreParentRunner env
-            , ysreGetSub = getSub . ysreGetSub env
-            , ysreToParentRoute = ysreToParentRoute env . toParent
-            , ysreParentEnv = ysreParentEnv env
-            })
-
 instanceD :: Cxt -> Type -> [Dec] -> Dec
 instanceD = InstanceD Nothing

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

@@ -8,7 +8,6 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
 module Yesod.Core.Types where
 
 import Data.Aeson (ToJSON)
@@ -56,7 +55,7 @@ import           Control.Monad.Reader               (MonadReader (..))
 import Control.DeepSeq (NFData (rnf))
 import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
 import Control.Monad.Logger (MonadLoggerIO (..))
-import UnliftIO (MonadUnliftIO (..), SomeException)
+import UnliftIO (MonadUnliftIO (..))
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -183,11 +182,6 @@ data RunHandlerEnv child site = RunHandlerEnv
       --
       -- Since 1.2.0
     , rheMaxExpires :: !Text
-
-      -- | @since 1.6.24.0
-      --   catch function for rendering 500 pages on exceptions.
-      --   by default this is catch from unliftio (rethrows all async exceptions).
-    , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m =>  m a -> (SomeException -> m a) -> m a)
     }
 
 data HandlerData child site = HandlerData
@@ -202,13 +196,7 @@ data YesodRunnerEnv site = YesodRunnerEnv
     , yreSite           :: !site
     , yreSessionBackend :: !(Maybe SessionBackend)
     , yreGen            :: !(IO Int)
-    -- ^ Generate a random number uniformly distributed in the full
+    -- ^ Generate a random number
-    -- 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)
     }
 
@@ -243,7 +231,7 @@ data GHState = GHState
 
 -- | An extension of the basic WAI 'W.Application' datatype to provide extra
 -- features needed by Yesod. Users should never need to use this directly, as
--- the 'HandlerFor' monad and template haskell code should hide it away.
+-- the 'HandlerT' monad and template haskell code should hide it away.
 type YesodApp = YesodRequest -> ResourceT IO YesodResponse
 
 -- | A generic widget, allowing specification of both the subsite and master
@@ -295,10 +283,9 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
 --
 -- > PageContent url -> HtmlUrl url
 data PageContent url = PageContent
-    { pageTitle       :: !Html
+    { pageTitle :: !Html
-    , pageDescription :: !(Maybe Text)
+    , pageHead  :: !(HtmlUrl url)
-    , pageHead        :: !(HtmlUrl url)
+    , pageBody  :: !(HtmlUrl url)
-    , pageBody        :: !(HtmlUrl url)
     }
 
 data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
@@ -339,28 +326,11 @@ newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
 -- | Responses to indicate some form of an error occurred.
 data ErrorResponse =
       NotFound
-        -- ^ The requested resource was not found.
-        -- Examples of when this occurs include when an incorrect URL is used, or @yesod-persistent@'s 'get404' doesn't find a value.
-        -- HTTP status: 404.
     | InternalError !Text
-        -- ^ Some sort of unexpected exception.
-        -- If your application uses `throwIO` or `error` to throw an exception, this is the form it would take.
-        -- HTTP status: 500.
     | InvalidArgs ![Text]
-        -- ^ Indicates some sort of invalid or missing argument, like a missing query parameter or malformed JSON body.
-        -- Examples Yesod functions that send this include 'requireCheckJsonBody' and @Yesod.Auth.GoogleEmail2@.
-        -- HTTP status: 400.
     | NotAuthenticated
-        -- ^ Indicates the user is not logged in.
-        -- This is thrown when 'isAuthorized' returns 'AuthenticationRequired'.
-        -- HTTP code: 401.
     | PermissionDenied !Text
-        -- ^ Indicates the user doesn't have permission to access the requested resource.
-        -- This is thrown when 'isAuthorized' returns 'Unauthorized'.
-        -- HTTP code: 403.
     | BadMethod !H.Method
-        -- ^ Indicates the URL would have been valid if used with a different HTTP method (e.g. a GET was used, but only POST is handled.)
-        -- HTTP code: 405.
     deriving (Show, Eq, Generic)
 instance NFData ErrorResponse
 
@@ -394,7 +364,6 @@ data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :
 data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }
     deriving (Show, Eq)
 newtype Title = Title { unTitle :: Html }
-newtype Description = Description { unDescription :: Text }
 
 newtype Head url = Head (HtmlUrl url)
     deriving Monoid
@@ -410,7 +379,6 @@ type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder
 data GWData a = GWData
     { gwdBody        :: !(Body a)
     , gwdTitle       :: !(Last Title)
-    , gwdDescription :: !(Last Description)
     , gwdScripts     :: !(UniqueList (Script a))
     , gwdStylesheets :: !(UniqueList (Stylesheet a))
     , gwdCss         :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type
@@ -418,21 +386,20 @@ data GWData a = GWData
     , gwdHead        :: !(Head a)
     }
 instance Monoid (GWData a) where
-    mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty
+    mempty = GWData mempty mempty mempty mempty mempty mempty mempty
 #if !(MIN_VERSION_base(4,11,0))
     mappend = (<>)
 #endif
 instance Semigroup (GWData a) where
-    GWData a1 a2 a3 a4 a5 a6 a7 a8 <>
+    GWData a1 a2 a3 a4 a5 a6 a7 <>
-      GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData
+      GWData b1 b2 b3 b4 b5 b6 b7 = GWData
         (mappend a1 b1)
         (mappend a2 b2)
         (mappend a3 b3)
         (mappend a4 b4)
-        (mappend a5 b5)
+        (unionWith mappend a5 b5)
-        (unionWith mappend a6 b6)
+        (mappend a6 b6)
         (mappend a7 b7)
-        (mappend a8 b8)
 
 data HandlerContents =
       HCContent !H.Status !TypedContent
@@ -489,7 +456,7 @@ instance MonadLogger (WidgetFor site) where
 instance MonadLoggerIO (WidgetFor site) where
     askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
 
--- Instances for HandlerFor
+-- Instances for HandlerT
 instance Applicative (HandlerFor site) where
     pure = HandlerFor . const . return
     (<*>) = ap

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

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

yesod-core/src/Yesod/Routes/Parse.hs

@@ -11,7 +11,6 @@ module Yesod.Routes.Parse
     , TypeTree (..)
     , dropBracket
     , nameToType
-    , isTvar
     ) where
 
 import Language.Haskell.TH.Syntax
@@ -36,15 +35,9 @@ parseRoutes = QuasiQuoter { quoteExp = x }
             [] -> lift res
             z -> error $ unlines $ "Overlapping routes: " : map show z
 
--- | Same as 'parseRoutes', but uses an external file instead of quasiquotation.
---
--- The recommended file extension is @.yesodroutes@.
 parseRoutesFile :: FilePath -> Q Exp
 parseRoutesFile = parseRoutesFileWith parseRoutes
 
--- | Same as 'parseRoutesNoCheck', but uses an external file instead of quasiquotation.
---
--- The recommended file extension is @.yesodroutes@.
 parseRoutesFileNoCheck :: FilePath -> Q Exp
 parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck
 
@@ -265,13 +258,8 @@ ttToType (TTApp x y) = ttToType x `AppT` ttToType y
 ttToType (TTList t) = ListT `AppT` ttToType t
 
 nameToType :: String -> Type
-nameToType t = if isTvar t
+nameToType t@(h:_) | isLower h = VarT $ mkName t
-               then VarT $ mkName t
+nameToType t = ConT $ mkName t
-               else ConT $ mkName t
-
-isTvar :: String -> Bool
-isTvar (h:_) = isLower h
-isTvar _     = False
 
 pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
 pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)

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

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

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

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

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

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

yesod-core/test/RouteSpec.hs

@@ -227,7 +227,7 @@ main = hspec $ do
     describe "routing table parsing" $ do
         it "recognizes trailing backslashes as line continuation directives" $ do
             let routes :: [ResourceTree String]
-                routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations.yesodroutes")
+                routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations")
             length routes @?= 3
 
     describe "overlap checking" $ do

yesod-core/test/YesodCoreTest.hs

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

yesod-core/test/YesodCoreTest/Breadcrumb.hs

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

yesod-core/test/YesodCoreTest/ErrorHandling.hs

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

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

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

yesod-core/test/YesodCoreTest/Meta.hs

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

yesod-core/test/YesodCoreTest/ParameterizedSite.hs

@@ -1,37 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module YesodCoreTest.ParameterizedSite
-    ( parameterizedSiteTest
-    ) where
-
-import Data.ByteString.Lazy (ByteString)
-import Network.Wai.Test (runSession, request, defaultRequest, assertBodyContains)
-import Test.Hspec (Spec, describe, it)
-import Yesod.Core (YesodDispatch)
-import Yesod.Core.Dispatch (toWaiApp)
-
-import YesodCoreTest.ParameterizedSite.PolyAny (PolyAny (..))
-import YesodCoreTest.ParameterizedSite.PolyShow (PolyShow (..))
-import YesodCoreTest.ParameterizedSite.Compat (Compat (..))
-
--- These are actually tests for template haskell. So if it compiles, it works
-parameterizedSiteTest :: Spec
-parameterizedSiteTest = describe "Polymorphic Yesod sites" $ do
-    it "Polymorphic unconstrained stub" $ runStub (PolyAny ())
-    it "Polymorphic stub with Show" $ runStub' "1337" (PolyShow 1337)
-    it "Polymorphic unconstrained stub, old-style" $ runStub (Compat () ())
-
-runStub :: YesodDispatch a => a -> IO ()
-runStub stub =
-    let actions = do
-            res <- request defaultRequest
-            assertBodyContains "Stub" res
-    in toWaiApp stub >>= runSession actions
-
-
-runStub' :: YesodDispatch a => ByteString -> a -> IO ()
-runStub' body stub =
-    let actions = do
-            res <- request defaultRequest
-            assertBodyContains "Stub" res
-            assertBodyContains body res
-    in toWaiApp stub >>= runSession actions

yesod-core/test/YesodCoreTest/ParameterizedSite/Compat.hs

@@ -1,27 +0,0 @@
-{-# LANGUAGE
-    TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
-  , OverloadedStrings, StandaloneDeriving, FlexibleInstances
-  #-}
-module YesodCoreTest.ParameterizedSite.Compat
-    ( Compat (..)
-    ) where
-
-import Yesod.Core
-
--- | Parameterized without constraints, and we call mkYesod without type vars,
--- like people used to do before the last 3 commits
-data Compat a b = Compat a b
-
-mkYesod "Compat" [parseRoutes|
-/ HomeR GET
-|]
-
-instance Yesod (Compat a b)
-
-getHomeR :: Handler a b Html
-getHomeR = defaultLayout
-    [whamlet|
-        <p>
-            Stub
-    |]
-

yesod-core/test/YesodCoreTest/ParameterizedSite/PolyAny.hs

@@ -1,26 +0,0 @@
-{-# LANGUAGE
-    TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
-  , OverloadedStrings, StandaloneDeriving, FlexibleInstances
-  #-}
-module YesodCoreTest.ParameterizedSite.PolyAny
-    ( PolyAny (..)
-    ) where
-
-import Yesod.Core
-
--- | Parameterized without constraints
-data PolyAny a = PolyAny a
-
-mkYesod "PolyAny a" [parseRoutes|
-/ HomeR GET
-|]
-
-instance Yesod (PolyAny a)
-
-getHomeR :: Handler a Html
-getHomeR = defaultLayout
-    [whamlet|
-        <p>
-            Stub
-    |]
-

yesod-core/test/YesodCoreTest/ParameterizedSite/PolyShow.hs

@@ -1,28 +0,0 @@
-{-# LANGUAGE
-    TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
-  , OverloadedStrings, StandaloneDeriving, FlexibleInstances
-  #-}
-module YesodCoreTest.ParameterizedSite.PolyShow
-    ( PolyShow (..)
-    ) where
-
-import Yesod.Core
-
--- | Parameterized with 'Show' constraint
-data PolyShow a = PolyShow a
-
-mkYesod "(Show a) => PolyShow a" [parseRoutes|
-/ HomeR GET
-|]
-
-instance Show a => Yesod (PolyShow a)
-
-getHomeR :: Show a => Handler a Html
-getHomeR = do
-    PolyShow x <- getYesod
-    defaultLayout
-        [whamlet|
-            <p>
-                Stub #{show x}
-        |]
-

yesod-core/test/YesodCoreTest/SubSub.hs

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

yesod-core/test/YesodCoreTest/SubSubData.hs

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

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 = toWaiAppPlain Y >>= runSession f
+runner f = toWaiApp 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.25.1
+version:         1.6.18.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -8,7 +8,7 @@ synopsis:        Creation of type-safe, RESTful web applications.
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-core>
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.10
+cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 extra-source-files:
@@ -17,17 +17,15 @@ extra-source-files:
   test/YesodCoreTest/JsLoaderSites/Bottom.hs
   test/en.msg
   test/test.hs
-  test/fixtures/routes_with_line_continuations.yesodroutes
+  test/fixtures/routes_with_line_continuations
   ChangeLog.md
   README.md
 
 library
-    default-language: Haskell2010
     hs-source-dirs: src
 
     build-depends:   base                  >= 4.10     && < 5
                    , aeson                 >= 1.0
-                   , attoparsec-aeson      >= 2.1
                    , auto-update
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.7.1
@@ -40,7 +38,6 @@ library
                    , containers            >= 0.2
                    , cookie                >= 0.4.3    && < 0.5
                    , deepseq               >= 1.3
-                   , entropy
                    , fast-logger           >= 2.2
                    , http-types            >= 0.7
                    , memory
@@ -49,7 +46,7 @@ library
                    , parsec                >= 2        && < 3.2
                    , path-pieces           >= 0.1.2    && < 0.3
                    , primitive             >= 0.6
-                   , random                >= 1.0.0.2  && < 1.3
+                   , random                >= 1.0.0.2  && < 1.2
                    , resourcet             >= 1.2
                    , shakespeare           >= 2.0
                    , template-haskell      >= 2.11
@@ -59,7 +56,7 @@ library
                    , unix-compat
                    , unliftio
                    , unordered-containers  >= 0.2
-                   , vector                >= 0.9      && < 0.14
+                   , vector                >= 0.9      && < 0.13
                    , wai                   >= 3.2
                    , wai-extra             >= 3.0.7
                    , wai-logger            >= 0.2
@@ -100,12 +97,14 @@ library
                      Yesod.Routes.TH.RouteAttrs
 
     ghc-options:     -Wall
+    -- Following line added due to: https://github.com/yesodweb/yesod/issues/545
+    -- This looks like a GHC bug
+    extensions:      MultiParamTypeClasses
 
     -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
-    other-extensions:      TemplateHaskell
+    extensions:      TemplateHaskell
 
 test-suite test-routes
-    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: RouteSpec.hs
     hs-source-dirs: test, src
@@ -122,7 +121,7 @@ test-suite test-routes
                    Yesod.Routes.TH.Types
 
     -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
-    other-extensions:      TemplateHaskell
+    extensions:      TemplateHaskell
 
     build-depends: base
                  , hspec
@@ -135,7 +134,6 @@ test-suite test-routes
                  , HUnit
 
 test-suite tests
-    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: test.hs
     hs-source-dirs: test
@@ -147,7 +145,6 @@ test-suite tests
                    YesodCoreTest.Header
                    YesodCoreTest.Csrf
                    YesodCoreTest.ErrorHandling
-                   YesodCoreTest.ErrorHandling.CustomApp
                    YesodCoreTest.Exceptions
                    YesodCoreTest.InternalRequest
                    YesodCoreTest.JsLoader
@@ -157,13 +154,8 @@ test-suite tests
                    YesodCoreTest.LiteApp
                    YesodCoreTest.Media
                    YesodCoreTest.MediaData
-                   YesodCoreTest.Meta
                    YesodCoreTest.NoOverloadedStrings
                    YesodCoreTest.NoOverloadedStringsSub
-                   YesodCoreTest.ParameterizedSite
-                   YesodCoreTest.ParameterizedSite.Compat
-                   YesodCoreTest.ParameterizedSite.PolyAny
-                   YesodCoreTest.ParameterizedSite.PolyShow
                    YesodCoreTest.RawResponse
                    YesodCoreTest.Redirect
                    YesodCoreTest.Reps
@@ -174,8 +166,6 @@ test-suite tests
                    YesodCoreTest.StubSslOnly
                    YesodCoreTest.StubStrictSameSite
                    YesodCoreTest.StubUnsecured
-                   YesodCoreTest.SubSub
-                   YesodCoreTest.SubSubData
                    YesodCoreTest.WaiSubsite
                    YesodCoreTest.Widget
                    YesodCoreTest.YesodTest
@@ -207,10 +197,9 @@ test-suite tests
                   , warp
                   , yesod-core
     ghc-options:     -Wall -threaded
-    other-extensions: TemplateHaskell
+    extensions: TemplateHaskell
 
 benchmark widgets
-    default-language: Haskell2010
     type: exitcode-stdio-1.0
     hs-source-dirs: bench
     build-depends:  base

yesod-eventsource/ChangeLog.md

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

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 'HandlerFor' action
+-- | Return a Server-Sent Event stream given a 'HandlerT' action
 -- that is repeatedly called.  A state is threaded for the action
--- so that it may avoid using @IORefs@.  The @HandlerFor@ action
+-- so that it may avoid using @IORefs@.  The @HandlerT@ action
 -- may sleep or block while waiting for more data.  The HTTP
 -- socket is flushed after every list of simultaneous events.
 -- The connection is closed as soon as an 'ES.CloseEvent' is

yesod-eventsource/yesod-eventsource.cabal

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

yesod-form-multi/ChangeLog.md

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

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

@@ -17,19 +17,16 @@ module Yesod.Form.MultiInput
     , mmulti
     , amulti
     , bs3Settings
-    , bs3FASettings
     , bs4Settings
-    , bs4FASettings
     ) where
 
 import Control.Arrow (second)
 import Control.Monad (liftM)
 import Control.Monad.Trans.RWS (ask, tell)
 import qualified Data.Map as Map
-import Data.Maybe (fromJust, listToMaybe, fromMaybe, isJust)
+import Data.Maybe (fromJust, listToMaybe, fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Text.Julius (rawJS)
 import Yesod.Core
 import Yesod.Form.Fields (intField)
 import Yesod.Form.Functions
@@ -44,132 +41,43 @@ instance ToJavascript Text where toJavascript = toJavascript . toJSON
 #endif
 #endif
 
--- | By default delete buttons have a @margin-left@ property of @0.75rem@.
+-- @since 1.6.0
--- 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.
     }
 
--- | The general structure of each individually generated field is as follows.
+-- @since 1.6.0
--- 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
+bs3Settings = MultiSettings "btn btn-default" (Just errW)
-    "btn btn-default"
-    "btn btn-danger"
-    "help-block"
-    "has-error"
-    Nothing Nothing (Just errW)
     where
         errW err = 
             [whamlet|
-                <span .help-block>#{err}
+                <span .help-block .error-block>#{err}
             |]
 
 -- | 'MultiSettings' for Bootstrap 4.
 --
 -- @since 1.6.0
 bs4Settings :: MultiSettings site
-bs4Settings = MultiSettings
+bs4Settings = MultiSettings "btn btn-basic" (Just errW)
-    "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
@@ -184,19 +92,20 @@ amulti field fs defs minVals ms = formToAForm $
         mform = do
             (fr, MultiView {..}) <- mmulti field fs defs minVals ms
 
-            let (fv : _) = mvFields
+            let widget = do
-                widget = do
                     [whamlet|
-                        $maybe tooltip <- fvTooltip fv
-                            <small .#{msTooltipClass ms}>#{tooltip}
-
                         ^{fvInput mvCounter}
 
                         $forall fv <- mvFields
                             ^{fvInput fv}
 
+                            $maybe err <- fvErrors fv
+                                $maybe errW <- msErrWidget ms
+                                    ^{errW err}
+
                         ^{fvInput mvAddBtn}
                     |]
+                (fv : _) = mvFields
                 view = FieldView
                     { fvLabel = fvLabel fv
                     , fvTooltip = Nothing
@@ -221,10 +130,11 @@ mmulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
     -> Int
     -> MultiSettings site
     -> MForm m (FormResult [a], MultiView site)
-mmulti field fs defs minVals' ms = do
+mmulti field fs@FieldSettings {..} defs minVals ms = do
-    wrapperClass <- lift newIdent
+    fieldClass <- newFormIdent
-    let minVals = if minVals' < 0 then 0 else minVals'
+    let fs' = fs {fsAttrs = addClass fieldClass fsAttrs}
-    mhelperMulti field fs wrapperClass defs minVals ms
+        minVals' = if minVals < 0 then 0 else minVals
+    mhelperMulti field fs' fieldClass defs minVals' ms
 
 -- Helper function, does most of the work for mmulti.
 mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
@@ -235,22 +145,21 @@ mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMe
     -> Int
     -> MultiSettings site
     -> MForm m (FormResult [a], MultiView site)
-mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals MultiSettings {..} = do
+mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals MultiSettings {..} = do
     mp <- askParams
     (_, site, langs) <- ask
     name <- maybe newFormIdent return fsName
-    theId <- lift $ maybe newIdent return fsId
+    theId <- maybe newFormIdent return fsId
     cName <- newFormIdent
-    cid <- lift newIdent
+    cid <- newFormIdent
-    addBtnId <- lift newIdent
+    addBtnId <- newFormIdent 
-    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 = [(i, (mkName i, mkId i)) | i <- [0 .. c]]
+        mkNames c = [(mkName i, mkId i) | i <- [0 .. c]]
         onMissingSucc _ _ = FormSuccess Nothing
         onMissingFail m l = FormFailure [renderMessage m l MsgValueRequired]
         isSuccNothing r = case r of
@@ -265,7 +174,7 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
         Just p -> mkRes intField cfs p mfs cName onMissingFail FormSuccess
 
     -- generate counter view
-    cView <- mkView intField cfs cr Nothing Nothing msWrapperErrClass cid cName True
+    cView <- mkView intField cfs cr cid cName True
 
     let counter = case cRes of
             FormSuccess c -> c
@@ -277,74 +186,17 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
             if cDef == 0
                 then [(FormMissing, Left "")]
                 else [(FormMissing, Right d) | d <- defs]
-        Just p -> mapM
+        Just p -> mapM (\n -> mkRes field fs p mfs n onMissingSucc (FormSuccess . Just)) (map fst $ mkNames counter)
-            (\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' ((c, (n,i)), r@(res, _)) = do
+        let mkView' ((n,i), r@(res, _)) = do
-                let del = Just (mkDelBtn i, wrapperClass, c)
+                fv <- mkView field fs r i n False
-                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
-                [] -> [((0, (mkName 0, mkId 0)), (FormSuccess Nothing, Left ""))] -- always need at least one value to generate a field
+                [] -> [((mkName 0, mkId 0), (FormSuccess Nothing, Left ""))] -- always need at least one value to generate a field
                 zs -> zs
         rvs <- mapM mkView' ys
         return $ unzip rvs
@@ -362,77 +214,23 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
                 fRes -> (fRes, False)
     
         -- create add button
-        -- also includes some styling / functions that we only want to include once
         btnWidget = do
             [whamlet|
-                <button ##{addBtnId} .#{msAddClass} type="button">
+                <button ##{addBtnId} .#{msAddClass} type="button">Add Another
-                    $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_#{rawJS theId} = 0;
+                    var extraFields = 0;
-                    $('##{rawJS addBtnId}').click(function() {
+                    $("#" + #{addBtnId}).click(function() {
-                        extraFields_#{rawJS theId}++;
+                        extraFields++;
-                        var newNumber = parseInt(#{show counter}) + extraFields_#{rawJS theId};
+                        var newNumber = parseInt(#{show counter}) + extraFields;
                         $("#" + #{cid}).val(newNumber);
                         var newName = #{name} + "-" + newNumber;
                         var newId = #{theId} + "-" + newNumber;
-                        var newDelId = #{delBtnPrefix} + newId;
                         
-                        // get new wrapper and remove old error messages
+                        var newElem = $("." + #{fieldClass}).first().clone();
-                        var newWrapper = $('.#{rawJS wrapperClass}').first().clone();
+                        newElem.val("").attr('name', newName).attr('id', newId);
-                        newWrapper.children( ':not(.#{rawJS wrapperClass}-inner)' ).remove();
+                        newElem.insertBefore("#" + #{addBtnId})
-                        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}');
                     });
                 |]
 
@@ -445,7 +243,7 @@ mhelperMulti field@Field {..} fs@FieldSettings {..} wrapperClass defs minVals Mu
             , fvRequired = False
             }
 
-    return (res, MultiView cView fvs btnView wrapperClass)
+    return (res, MultiView cView fvs btnView)
 
 -- Search for the given field's name in the environment,
 -- parse any values found and construct a FormResult.
@@ -476,42 +274,21 @@ mkView :: (site ~ HandlerSite m, MonadHandler m)
     => Field m a
     -> FieldSettings site
     -> (FormResult b, Either Text a)
-    -- Delete button widget, class for div wrapping each field with it's delete button and counter value for that field.
-    -- Nothing if the field passed doesn't need a delete button e.g. if it is the counter field.
-    -> Maybe (WidgetFor site (), Text, Int)
-    -> Maybe (Html -> WidgetFor site ()) -- Function to display error messages.
-    -> Text
     -> Text
     -> Text
     -> Bool
     -> MForm m (FieldView site)
-mkView Field {..} FieldSettings {..} (res, val) mdel merrW errClass theId name isReq = do
+mkView Field {..} FieldSettings {..} (res, val) theId name isReq = do
     (_, site, langs) <- ask
     let mr2 = renderMessage site langs
-        merr = case res of
-                FormFailure [e] -> Just $ toHtml e
-                _ -> Nothing
-        fv' = fieldView theId name fsAttrs val isReq
-        fv = do
-            [whamlet|
-                $maybe (delBtn, wrapperClass, counter) <- mdel
-                    <div .#{wrapperClass} :isJust merr:.#{errClass} data-counter=#{counter}>
-                        <div .#{wrapperClass}-inner>
-                            ^{fv'}
-                            ^{delBtn}
-                            
-                        $maybe err <- merr
-                            $maybe errW <- merrW
-                                ^{errW err}
-                        
-                $nothing
-                    ^{fv'}
-            |]
     return $ FieldView
         { fvLabel = toHtml $ mr2 fsLabel
         , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
         , fvId = theId
-        , fvInput = fv
+        , fvInput = fieldView theId name fsAttrs val isReq
-        , fvErrors = merr
+        , fvErrors =
+            case res of
+                FormFailure [e] -> Just $ toHtml e
+                _ -> Nothing
         , fvRequired = isReq
         }

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

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

yesod-form/ChangeLog.md

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

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 provides a set of basic form inputs such as text, number, time,
+This package provies a set of basic form inputs such as text, number, time,
 checkbox, select, textarea, and etc. via `Yesod.Form.Fields` module.  Also,
 there is `Yesod.Form.Nic` module providing richtext field using Nic editor.
 However, this module is grandfathered now and Nic editor is not actively

yesod-form/Yesod/Form/Fields.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE CPP #-}
 -- | Field functions allow you to easily create and validate forms, cleanly handling the uncertainty of parsing user input.
@@ -46,10 +45,8 @@ module Yesod.Form.Fields
     , selectFieldHelper
     , selectField
     , selectFieldList
-    , selectFieldListGrouped
     , radioField
     , radioFieldList
-    , withRadioField
     , checkboxesField
     , checkboxesFieldList
     , multiSelectField
@@ -57,14 +54,10 @@ module Yesod.Form.Fields
     , Option (..)
     , OptionList (..)
     , mkOptionList
-    , mkOptionListGrouped
     , optionsPersist
     , optionsPersistKey
     , optionsPairs
-    , optionsPairsGrouped
     , optionsEnum
-    , colorField
-    , datetimeLocalField
     ) where
 
 import Yesod.Form.Types
@@ -75,7 +68,7 @@ import Text.Blaze (ToMarkup (toMarkup), unsafeByteString)
 #define ToHtml ToMarkup
 #define toHtml toMarkup
 #define preEscapedText preEscapedToMarkup
-import Data.Time (Day, TimeOfDay(..), LocalTime (LocalTime))
+import Data.Time (Day, TimeOfDay(..))
 import qualified Text.Email.Validate as Email
 import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
@@ -87,7 +80,7 @@ import Database.Persist (Entity (..), SqlType (SqlString), PersistRecordBackend,
 import Database.Persist (Entity (..), SqlType (SqlString), PersistEntity, PersistQuery, PersistEntityBackend)
 #endif
 import Text.HTML.SanitizeXSS (sanitizeBalance)
-import Control.Monad (when, unless, forM_)
+import Control.Monad (when, unless)
 import Data.Either (partitionEithers)
 import Data.Maybe (listToMaybe, fromMaybe)
 
@@ -99,8 +92,7 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
 import Data.Text as T ( Text, append, concat, cons, head
-                      , intercalate, isPrefixOf, null, unpack, pack
+                      , intercalate, isPrefixOf, null, unpack, pack, splitOn
-                      , split, splitOn
                       )
 import qualified Data.Text as T (drop, dropWhile)
 import qualified Data.Text.Read
@@ -121,8 +113,6 @@ import Data.String (IsString)
 import Data.Monoid
 #endif
 
-import Data.Char (isHexDigit)
-
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
 
@@ -182,7 +172,7 @@ timeField = timeFieldTypeTime
 -- 
 -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
 --
--- @since 1.4.2
+-- Since 1.4.2
 timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay  
 timeFieldTypeTime = timeFieldOfType "time"
 
@@ -192,7 +182,7 @@ timeFieldTypeTime = timeFieldOfType "time"
 -- 
 -- 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"
 
@@ -372,7 +362,7 @@ $newline never
 
 -- | Creates an input with @type="email"@ with the <http://w3c.github.io/html/sec-forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'.
 --
--- @since 1.3.7
+-- Since 1.3.7
 multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
 multiEmailField = Field
     { fieldParse = parseHelper $
@@ -437,15 +427,7 @@ selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg
                 -> Field (HandlerFor site) a
 selectFieldList = selectField . optionsPairs
 
--- | Creates a @\<select>@ tag with @\<optgroup>@s for selecting one option.
+-- | Creates a @\<select>@ tag for selecting one option. Example usage:
---
--- @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)
@@ -464,9 +446,6 @@ $newline never
 $newline never
 <option value=#{value} :isSel:selected>#{text}
 |]) -- inside
-    (Just $ \label -> [whamlet|
-<optgroup label=#{label}>
-|]) -- group label
 
 -- | Creates a @\<select>@ tag for selecting multiple options.
 multiSelectFieldList :: (Eq a, RenderMessage site msg)
@@ -533,52 +512,25 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
 radioField :: (Eq a, RenderMessage site FormMessage)
            => HandlerFor site (OptionList a)
            -> Field (HandlerFor site) a
-radioField = withRadioField
+radioField = selectFieldHelper
-    (\theId optionWidget -> [whamlet|
+    (\theId _name _attrs inside -> [whamlet|
 $newline never
-<div .radio>
+<div ##{theId}>^{inside}
-    <label for=#{theId}-none>
-        <div>
-            ^{optionWidget}
-            _{MsgSelectNone}
 |])
-    (\theId value _isSel text optionWidget -> [whamlet|
+    (\theId name isSel -> [whamlet|
 $newline never
-<div .radio>
+<label .radio for=#{theId}-none>
-    <label for=#{theId}-#{value}>
+    <div>
-        <div>
+        <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
-            ^{optionWidget}
+        _{MsgSelectNone}
-            \#{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
-<div ##{theId}>^{inside'}
+<label .radio for=#{theId}-#{value}>
-|]
+    <div>
-    onOpt theId name isSel = nothingFun theId $ [whamlet|
+        <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
-$newline never
+        \#{text}
-<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.
 --
@@ -646,31 +598,15 @@ $newline never
         showVal = either (\_ -> False)
 
 -- | A structure holding a list of options. Typically you can use a convenience function like 'mkOptionList' or 'optionsPairs' instead of creating this directly.
---
+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').
-    }
 
--- | Convert grouped 'OptionList' to a normal one.
+-- | Since 1.4.6
---
--- @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) = 
       OptionList ((fmap.fmap) f options) (fmap f . readExternal)
-    fmap f (OptionListGrouped options readExternal) =
-      OptionListGrouped (map (\(g, os) -> (g, (fmap.fmap) f os)) options) (fmap f . readExternal)
 
 -- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternal' function.
 mkOptionList :: [Option a] -> OptionList a
@@ -679,22 +615,13 @@ mkOptionList os = OptionList
     , olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os
     }
 
--- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternalGrouped' function.
---
--- @since 1.7.0
-mkOptionListGrouped :: [(Text, [Option a])] -> OptionList a
-mkOptionListGrouped os = OptionListGrouped
-    { olOptionsGrouped = os
-    , olReadExternalGrouped = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) $ concatMap snd os
-    }
-
 data Option a = Option
     { optionDisplay :: Text -- ^ The user-facing label.
     , optionInternalValue :: a -- ^ The Haskell value being selected.
     , optionExternalValue :: Text -- ^ The representation of this value stored in the form.
     }
 
--- | @since 1.4.6
+-- | Since 1.4.6
 instance Functor Option where
     fmap f (Option display internal external) = Option display (f internal) external
 
@@ -710,30 +637,6 @@ optionsPairs opts = do
                  }
   return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
 
--- | Creates an 'OptionList' from a list of (display-value, internal value) pairs.
---
--- @since 1.7.0
-optionsPairsGrouped
-  :: forall m msg a. (MonadHandler m, RenderMessage (HandlerSite m) msg)
-  => [(msg, [(msg, a)])] -> m (OptionList a)
-optionsPairsGrouped opts = do
-  mr <- getMessageRender
-  let mkOption (external, (display, internal)) =
-          Option { optionDisplay       = mr display
-                 , optionInternalValue = internal
-                 , optionExternalValue = pack $ show external
-                 }
-      opts' = enumerateSublists opts :: [(msg, [(Int, (msg, a))])]
-      opts'' = map (\(x, ys) -> (mr x, map mkOption ys)) opts'
-  return $ mkOptionListGrouped opts''
-
--- | Helper to enumerate sublists with one consecutive index.
-enumerateSublists :: forall a b. [(a, [b])] -> [(a, [(Int, b)])]
-enumerateSublists xss =
-  let yss :: [(Int, (a, [b]))]
-      yss = snd $ foldl (\(i, res) xs -> (i + (length.snd) xs, res ++ [(i, xs)])) (1, []) xss
-   in map (\(i, (x, ys)) -> (x, zip [i :: Int ..] ys)) yss
-
 -- | Creates an 'OptionList' from an 'Enum', using its 'Show' instance for the user-facing value.
 optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
 optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
@@ -789,7 +692,7 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
 -- | An alternative to 'optionsPersist' which returns just the 'Key' instead of
 -- the entire 'Entity'.
 --
--- @since 1.3.2
+-- Since 1.3.2
 #if MIN_VERSION_persistent(2,5,0)
 optionsPersistKey
   :: (YesodPersist site
@@ -828,7 +731,7 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
         }) pairs
 
 -- |
--- A helper function for constucting 'selectField's with optional option groups. You may want to use this when you define your custom 'selectField's or 'radioField's.
+-- A helper function for constucting 'selectField's. You may want to use this when you define your custom 'selectField's or 'radioField's.
 --
 -- @since 1.6.2
 selectFieldHelper
@@ -836,26 +739,23 @@ selectFieldHelper
         => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()) -- ^ Outermost part of the field
         -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional
         -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options
-        -> (Maybe (Text -> WidgetFor site ())) -- ^ Group headers placed inbetween options
         -> HandlerFor site (OptionList a)
         -> Field (HandlerFor site) a
-selectFieldHelper outside onOpt inside grpHdr opts' = Field
+selectFieldHelper outside onOpt inside opts' = Field
     { fieldParse = \x _ -> do
-        opts <- fmap flattenOptionList opts'
+        opts <- opts'
         return $ selectParser opts x
     , fieldView = \theId name attrs val isReq -> do
+        opts <- fmap olOptions $ handlerToWidget opts'
         outside theId name attrs $ do
-          optsFlat <- fmap (olOptions.flattenOptionList) $ handlerToWidget opts'
+            unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
-          unless isReq $ onOpt theId name $ render optsFlat val `notElem` map optionExternalValue optsFlat
+            flip mapM_ opts $ \opt -> inside
-          opts'' <- handlerToWidget opts'
+                theId
-          case opts'' of
+                name
-            OptionList{} -> constructOptions theId name attrs val isReq optsFlat
+                ((if isReq then (("required", "required"):) else id) attrs)
-            OptionListGrouped{olOptionsGrouped=grps} -> do
+                (optionExternalValue opt)
-                  forM_ grps $ \(grp, opts) -> do
+                ((render opts val) == optionExternalValue opt)
-                    case grpHdr of
+                (optionDisplay opt)
-                      Just hdr -> hdr grp
-                      Nothing -> return ()
-                    constructOptions theId name attrs val isReq opts
     , fieldEnctype = UrlEncoded
     }
   where
@@ -868,14 +768,6 @@ selectFieldHelper outside onOpt inside grpHdr opts' = Field
             x -> case olReadExternal opts x of
                     Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
                     Just y -> Right $ Just y
-    constructOptions theId name attrs val isReq opts =
-      forM_ opts $ \opt -> inside
-                           theId
-                           name
-                           ((if isReq then (("required", "required"):) else id) attrs)
-                           (optionExternalValue opt)
-                           (render opts val == optionExternalValue opt)
-                           (optionDisplay opt)
 
 -- | Creates an input with @type="file"@.
 fileField :: Monad m
@@ -972,7 +864,7 @@ 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.
@@ -980,44 +872,3 @@ prependZero t0 = if T.null t1
 -- 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,5 +24,3 @@ chineseFormMessage (MsgInvalidBool t) = "无效的逻辑值: " `mappend` t
 chineseFormMessage MsgBoolYes = "是"
 chineseFormMessage MsgBoolNo = "否"
 chineseFormMessage MsgDelete = "删除?"
-chineseFormMessage (MsgInvalidHexColorFormat t) = "颜色无效，必须为 #rrggbb 十六进制格式: " `mappend` t
-chineseFormMessage (MsgInvalidDatetimeFormat t) = "日期時間無效，必須採用 YYYY-MM-DD(T| )HH:MM[:SS] 格式： " `mappend` t

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

yesod-form/Yesod/Form/Types.hs

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

yesod-form/yesod-form.cabal

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

yesod-persistent/ChangeLog.md

@@ -1,21 +1,5 @@
 # ChangeLog for yesod-persistent
 
-## 1.6.0.8
-
-* Add support for `persistent-2.14` [#1706](https://github.com/yesodweb/yesod/pull/1760)
-
-## 1.6.0.7
-
-* Add support for persistent 2.13. [#1723](https://github.com/yesodweb/yesod/pull/1723)
-
-## 1.6.0.6
-
-* Add support for persistent 2.12
-
-## 1.6.0.5
-
-* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)
-
 ## 1.6.0.4
 
 * Fix test suite to be compatible with latest `persistent-template`

yesod-persistent/Yesod/Persist/Core.hs

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

@@ -1,5 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies #-}
 {-# LANGUAGE EmptyDataDecls, FlexibleContexts, GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}

yesod-persistent/yesod-persistent.cabal

@@ -1,6 +1,5 @@
-cabal-version:   >= 1.10
 name:            yesod-persistent
-version:         1.6.0.8
+version:         1.6.0.4
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -8,17 +7,17 @@ maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        Some helpers for using Persistent from Yesod.
 category:        Web, Yesod, Database
 stability:       Stable
+cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-persistent>
 extra-source-files: README.md ChangeLog.md
 
 library
-    default-language: Haskell2010
     build-depends:   base                      >= 4.10     && < 5
                    , yesod-core                >= 1.6      && < 1.7
-                   , persistent                >= 2.8
+                   , persistent                >= 2.8      && < 2.11
-                   , persistent-template       >= 2.1
+                   , persistent-template       >= 2.1      && < 2.9
                    , transformers              >= 0.2.2
                    , blaze-builder
                    , conduit
@@ -29,12 +28,10 @@ library
     ghc-options:     -Wall
 
 test-suite test
-    default-language: Haskell2010
     type: exitcode-stdio-1.0
     main-is: Spec.hs
     hs-source-dirs: test
     other-modules: Yesod.PersistSpec
-    build-tool-depends: hspec-discover:hspec-discover
     build-depends: base
                  , hspec
                  , wai-extra

yesod-static/ChangeLog.md

@@ -1,9 +1,3 @@
-# ChangeLog for yesod-static
-
-## 1.6.1.0
-
-* Support reproducible embedded file order [#1684](https://github.com/yesodweb/yesod/issues/1684#issuecomment-652562514)
-
 ## 1.6.0.2
 
 * Remove unnecessary deriving of Typeable

yesod-static/Yesod/EmbeddedStatic/Generators.hs

@@ -49,7 +49,6 @@ import qualified System.Process as Proc
 import System.Exit (ExitCode (ExitSuccess))
 import Control.Concurrent.Async (Concurrently (..))
 import System.IO (hClose)
-import Data.List (sort)
 
 import Yesod.EmbeddedStatic.Types
 
@@ -81,7 +80,7 @@ getRecursiveContents :: Location -- ^ The directory to search
                      -> FilePath   -- ^ The prefix to add to the filenames
                      -> IO [(Location,FilePath)]
 getRecursiveContents prefix topdir = do
-  names <- sort <$> getDirectoryContents topdir
+  names <- getDirectoryContents topdir
   let properNames = filter (`notElem` [".", ".."]) names
   paths <- forM properNames $ \name -> do
     let path = topdir </> name

yesod-static/Yesod/Static.hs

@@ -71,7 +71,7 @@ import Data.FileEmbed (embedDir)
 import Yesod.Core
 import Yesod.Core.Types
 
-import Data.List (intercalate, sort)
+import Data.List (intercalate)
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax as TH
 
@@ -192,7 +192,7 @@ getFileListPieces = flip evalStateT M.empty . flip go id
        -> ([String] -> [String])
        -> StateT (M.Map String String) IO [[String]]
     go fp front = do
-        allContents <- liftIO $ (sort . filter notHidden) `fmap` getDirectoryContents fp
+        allContents <- liftIO $ filter notHidden `fmap` getDirectoryContents fp
         let fullPath :: String -> String
             fullPath f = fp ++ '/' : f
         files <- liftIO $ filterM (doesFileExist . fullPath) allContents

yesod-static/yesod-static.cabal

@@ -1,5 +1,5 @@
 name:            yesod-static
-version:         1.6.1.0
+version:         1.6.0.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -7,7 +7,7 @@ maintainer:      Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweb
 synopsis:        Static file serving subsite for Yesod Web Framework.
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.10
+cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     API docs and the README are available at <http://www.stackage.org/package/yesod-static>
@@ -26,7 +26,6 @@ extra-source-files:
   README.md
 
 library
-    default-language: Haskell2010
     build-depends:   base                  >= 4.10     && < 5
                    , async
                    , attoparsec            >= 0.10
@@ -67,10 +66,9 @@ library
                      Yesod.EmbeddedStatic.Css.Util
 
     ghc-options:     -Wall
-    other-extensions: TemplateHaskell
+    extensions: TemplateHaskell
 
 test-suite tests
-    default-language: Haskell2010
     hs-source-dirs: ., test
     main-is: tests.hs
     type: exitcode-stdio-1.0
@@ -120,7 +118,7 @@ test-suite tests
                    , rio
 
     ghc-options:     -Wall -threaded
-    other-extensions: TemplateHaskell
+    extensions: TemplateHaskell
 
 source-repository head
   type:     git

yesod-test/ChangeLog.md

@@ -1,42 +1,8 @@
 # ChangeLog for yesod-test
 
-
-## 1.6.16
-
-* Add `addBareGetParam` to yesod-test. [#1821](https://github.com/yesodweb/yesod/pull/1821)
-
-## 1.6.15
-
-* Add `bySelectorLabelContain`. [#1781](https://github.com/yesodweb/yesod/pull/1781)
-
-## 1.6.14
-
-* Fix quotes not matching in htmlContain* functions [#1768](https://github.com/yesodweb/yesod/pull/1768).
-* Add logging of the matches found of these functions [#1768](https://github.com/yesodweb/yesod/pull/1768).
-* Improved failure messages from `assertEq`. [#1767](https://github.com/yesodweb/yesod/pull/1767)
-
-## 1.6.13
-
-* Add `Yesod.Test.Internal.SIO` module to expose the `SIO` type.
-
-## 1.6.12
-
-* Fix import in cookie example [#1713](https://github.com/yesodweb/yesod/pull/1713)
-* Add `MonadState` instance for `SIO`
-
-## 1.6.11
-
-* Add missing `HasCallStack`s [#1710](https://github.com/yesodweb/yesod/pull/1710)
-
-## 1.6.10
-
-* `statusIs` assertion failures now print a preview of the response body, if the response body is UTF-8 or ASCII. [#1680](https://github.com/yesodweb/yesod/pull/1680/files)
-* Adds an `Yesod.Test.Internal`, which exposes functions that yesod-test uses. These functions do _not_ constitute a stable API.
-
 ## 1.6.9.1
 
 * Improve documentation [#1676](https://github.com/yesodweb/yesod/pull/1676)
-* Require GHC 8.2 (base >= 4.10)
 
 ## 1.6.9
 

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.
-          byLabelExact "Email:" "gustavo@cerati.com"
+          byLabel "Email:" "gustavo@cerati.com"
-          byLabelExact "Password:" "secret"
+          byLabel "Password:" "secret"
-          byLabelExact "Confirm:" "secret"
+          byLabel "Confirm:" "secret"
 
       it "Sends another form, this one has a file" $ do
         request $ do

yesod-test/Yesod/Test.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 
 {-|
 Yesod.Test is a pragmatic framework for testing web applications built
@@ -152,7 +151,6 @@ module Yesod.Test
     , setMethod
     , addPostParam
     , addGetParam
-    , addBareGetParam
     , addFile
     , setRequestBody
     , RequestBuilder
@@ -171,7 +169,6 @@ module Yesod.Test
     , byLabelContain
     , byLabelPrefix
     , byLabelSuffix
-    , bySelectorLabelContain
     , fileByLabel
     , fileByLabelExact
     , fileByLabelContain
@@ -243,21 +240,23 @@ import qualified Network.Socket.Internal as Sock
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
-import qualified Text.Blaze.Renderer.String as Blaze
-import qualified Text.Blaze as Blaze
 import Network.Wai
 import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
+import Control.Monad.Trans.Reader (ReaderT (..))
+import Conduit (MonadThrow)
 import Control.Monad.IO.Class
 import System.IO
 import Yesod.Core.Unsafe (runFakeHandler)
 import Yesod.Test.TransversingCSS
 import Yesod.Core
+import Yesod.Core.Json (contentTypeHeaderIsJson)
 import qualified Data.Text.Lazy as TL
 import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With)
 import Text.XML.Cursor hiding (element)
 import qualified Text.XML.Cursor as C
 import qualified Text.HTML.DOM as HD
 import Control.Monad.Trans.Writer
+import Data.IORef
 import qualified Data.Map as M
 import qualified Web.Cookie as Cookie
 import qualified Blaze.ByteString.Builder as Builder
@@ -280,9 +279,6 @@ import Network.HTTP.Types.Header (hContentType)
 import Data.Aeson (FromJSON, eitherDecode')
 import Control.Monad (unless)
 
-import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8)
-import Yesod.Test.Internal.SIO
-
 {-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-}
 {-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-}
 
@@ -465,7 +461,7 @@ testModifySite newSiteFn = do
 --
 -- ==== __Examples__
 --
--- > import qualified Web.Cookie as Cookie
+-- > import qualified Data.Cookie as Cookie
 -- > :set -XOverloadedStrings
 -- > testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "name" }
 --
@@ -503,8 +499,7 @@ testClearCookies = do
 
 -- Performs a given action using the last response. Use this to create
 -- response-level assertions
-withResponse' :: HasCallStack
+withResponse' :: (state -> Maybe SResponse)
-              => (state -> Maybe SResponse)
               -> [T.Text]
               -> (SResponse -> SIO state a)
               -> SIO state a
@@ -518,7 +513,7 @@ withResponse' getter errTrace f = maybe err f . getter =<< getSIO
 
 -- | Performs a given action using the last response. Use this to create
 -- response-level assertions
-withResponse :: HasCallStack => (SResponse -> YesodExample site a) -> YesodExample site a
+withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a
 withResponse = withResponse' yedResponse []
 
 -- | Use HXT to parse a value from an HTML tag.
@@ -527,8 +522,7 @@ parseHTML :: HtmlLBS -> Cursor
 parseHTML html = fromDocument $ HD.parseLBS html
 
 -- | Query the last response using CSS selectors, returns a list of matched fragments
-htmlQuery' :: HasCallStack
+htmlQuery' :: (state -> Maybe SResponse)
-           => (state -> Maybe SResponse)
            -> [T.Text]
            -> Query
            -> SIO state [HtmlLBS]
@@ -538,7 +532,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 :: HasCallStack => Query -> YesodExample site [HtmlLBS]
+htmlQuery :: Query -> YesodExample site [HtmlLBS]
 htmlQuery = htmlQuery' yedResponse []
 
 -- | Asserts that the two given values are equal.
@@ -548,8 +542,10 @@ htmlQuery = htmlQuery' yedResponse []
 -- @since 1.5.2
 assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
 assertEq m a b =
-  liftIO $ HUnit.assertEqual msg a b
+  liftIO $ HUnit.assertBool msg (a == b)
-  where msg = "Assertion: " ++ m ++ "\n"
+  where msg = "Assertion: " ++ m ++ "\n" ++
+              "First argument:  " ++ ppShow a ++ "\n" ++
+              "Second argument: " ++ ppShow b ++ "\n"
 
 -- | Asserts that the two given values are not equal.
 --
@@ -573,25 +569,17 @@ assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample si
 assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b)
 
 -- | Assert the last response status is as expected.
--- If the status code doesn't match, a portion of the body is also printed to aid in debugging.
 --
 -- ==== __Examples__
 --
 -- > get HomeR
 -- > statusIs 200
 statusIs :: HasCallStack => Int -> YesodExample site ()
-statusIs number = do
+statusIs number = withResponse $ \ SResponse { simpleStatus = s } ->
-  withResponse $ \(SResponse status headers body) -> do
+  liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat
-    let mContentType = lookup hContentType headers
+    [ "Expected status was ", show number
-        isUTF8ContentType = maybe False contentTypeHeaderIsUtf8 mContentType
+    , " but received status was ", show $ H.statusCode s
-
+    ]
-    liftIO $ flip HUnit.assertBool (H.statusCode status == number) $ concat
-      [ "Expected status was ", show number
-      , " but received status was ", show $ H.statusCode status
-      , if isUTF8ContentType
-          then ". For debugging, the body was: " <> (T.unpack $ getBodyTextPreview body)
-          else ""
-      ]
 
 -- | Assert the given header key/value pair was returned.
 --
@@ -710,13 +698,8 @@ htmlAllContain query search = do
   matches <- htmlQuery query
   case matches of
     [] -> failure $ "Nothing matched css query: " <> query
-    _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search  ++ " matches: " ++ show matches) $
+    _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $
-          DL.all (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
+          DL.all (DL.isInfixOf 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.
@@ -733,8 +716,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 ++ " matches: " ++ show matches) $
+    _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search) $
-          DL.any (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
+          DL.any (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
 
 -- | Queries the HTML using a CSS selector, and fails if any matched
 -- element contains the given string (in other words, it is the logical
@@ -750,7 +733,7 @@ htmlAnyContain query search = do
 htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site ()
 htmlNoneContain query search = do
   matches <- htmlQuery query
-  case DL.filter (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches) of
+  case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of
     [] -> return ()
     found -> failure $ "Found " <> T.pack (show $ length found) <>
                 " instances of " <> T.pack search <> " in " <> query <> " elements"
@@ -791,7 +774,13 @@ requireJSONResponse = do
         isJSONContentType
         (failure $ T.pack $ "Expected `Content-Type: application/json` in the headers, got: " ++ show headers)
     case eitherDecode' body of
-        Left err -> failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err, "JSON: ", getBodyTextPreview body]
+        Left err -> do
+          let characterLimit = 1024
+              textBody = TL.toStrict $ decodeUtf8 body
+              bodyPreview = if T.length textBody < characterLimit
+                then textBody
+                else T.take characterLimit textBody <> "... (use `printBody` to see complete response body)"
+          failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err, "JSON: ", bodyPreview]
         Right v -> return v
 
 -- | Outputs the last response body to stderr (So it doesn't get captured by HSpec). Useful for debugging.
@@ -811,7 +800,7 @@ printBody = withResponse $ \ SResponse { simpleBody = b } ->
 -- > {-# LANGUAGE OverloadedStrings #-}
 -- > get HomeR
 -- > printMatches "h1" -- Prints all h1 tags
-printMatches :: HasCallStack => Query -> YesodExample site ()
+printMatches :: Query -> YesodExample site ()
 printMatches query = do
   matches <- htmlQuery query
   liftIO $ hPutStrLn stderr $ show matches
@@ -850,23 +839,6 @@ 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.
@@ -888,43 +860,16 @@ addFile name path mimetype = do
 
 -- |
 -- This looks up the name of a field based on the contents of the label pointing to it.
-genericNameFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
+genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
 genericNameFromLabel match label = do
   mres <- fmap rbdResponse getSIO
   res <-
     case mres of
       Nothing -> failure "genericNameFromLabel: No response available"
       Just res -> return res
-  let body = simpleBody res
-  case genericNameFromHTML match label body of
-    Left e -> failure e
-    Right x -> pure x
-
--- |
--- This looks up the name of a field based on a CSS selector and the contents of the label pointing to it.
-genericNameFromSelectorLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> T.Text -> RequestBuilder site T.Text
-genericNameFromSelectorLabel match selector label = do
-  mres <- fmap rbdResponse getSIO
-  res <-
-    case mres of
-      Nothing -> failure "genericNameSelectorFromLabel: No response available"
-      Just res -> return res
-  let body = simpleBody res
-  html <-
-    case findBySelector body selector of
-        Left parseError -> failure $ "genericNameFromSelectorLabel: Parse error" <> T.pack parseError
-        Right [] -> failure $ "genericNameFromSelectorLabel: No fragments match selector " <> selector
-        Right [matchingFragment] -> pure $ BSL8.pack matchingFragment
-        Right _matchingFragments -> failure $ "genericNameFromSelectorLabel: Multiple fragments match selector " <> selector
-  case genericNameFromHTML match label html of
-    Left e -> failure e
-    Right x -> pure x
-
-genericNameFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text
-genericNameFromHTML match label html =
   let
-    parsedHTML = parseHTML html
+    body = simpleBody res
-    mlabel = parsedHTML
+    mlabel = parseHTML body
                 $// C.element "label"
                 >=> isContentMatch label
     mfor = mlabel >>= attribute "for"
@@ -933,26 +878,26 @@ genericNameFromHTML match label html =
         | x `match` T.concat (c $// content) = [c]
         | otherwise = []
 
-  in case mfor of
+  case mfor of
     for:[] -> do
-      let mname = parsedHTML
+      let mname = parseHTML body
                     $// attributeIs "id" for
                     >=> attribute "name"
       case mname of
-        "":_ -> Left $ T.concat
+        "":_ -> failure $ T.concat
             [ "Label "
             , label
             , " resolved to id "
             , for
             , " which was not found. "
             ]
-        name:_ -> Right name
+        name:_ -> return name
-        [] -> Left $ "No input with id " <> for
+        [] -> failure $ "No input with id " <> for
     [] ->
       case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of
-        [] -> Left $ "No label contained: " <> label
+        [] -> failure $ "No label contained: " <> label
-        name:_ -> Right name
+        name:_ -> return name
-    _ -> Left $ "More than one label contained " <> label
+    _ -> failure $ "More than one label contained " <> label
 
 byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
                  -> T.Text                     -- ^ The text contained in the @\<label>@.
@@ -962,15 +907,6 @@ byLabelWithMatch match label value = do
   name <- genericNameFromLabel match label
   addPostParam name value
 
-bySelectorLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
-                 -> T.Text                     -- ^ The CSS selector.
-                 -> T.Text                     -- ^ The text contained in the @\<label>@.
-                 -> T.Text                     -- ^ The value to set the parameter to.
-                 -> RequestBuilder site ()
-bySelectorLabelWithMatch match selector label value = do
-  name <- genericNameFromSelectorLabel match selector label
-  addPostParam name value
-
 -- How does this work for the alternate <label><input></label> syntax?
 
 -- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter
@@ -1084,18 +1020,6 @@ byLabelSuffix :: T.Text -- ^ The text in the @\<label>@.
               -> RequestBuilder site ()
 byLabelSuffix = byLabelWithMatch T.isSuffixOf
 
--- |
--- Note: This function throws an error if it finds multiple labels or if the
--- CSS selector fails to parse, doesn't match any fragment, or matches multiple
--- fragments.
---
--- @since 1.6.15
-bySelectorLabelContain :: T.Text -- ^ The CSS selector.
-               -> T.Text -- ^ The text in the @\<label>@.
-               -> T.Text -- ^ The value to set the parameter to.
-               -> RequestBuilder site ()
-bySelectorLabelContain = bySelectorLabelWithMatch T.isInfixOf
-
 fileByLabelWithMatch  :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
                       -> T.Text                     -- ^ The text contained in the @\<label>@.
                       -> FilePath                   -- ^ The path to the file.
@@ -1208,7 +1132,7 @@ fileByLabelSuffix = fileByLabelWithMatch T.isSuffixOf
 --
 -- > request $ do
 -- >   addToken_ "#formID"
-addToken_ :: HasCallStack => Query -> RequestBuilder site ()
+addToken_ :: Query -> RequestBuilder site ()
 addToken_ scope = do
   matches <- htmlQuery' rbdResponse ["Tried to get CSRF token with addToken'"] $ scope <> " input[name=_token][type=hidden][value]"
   case matches of
@@ -1222,7 +1146,7 @@ addToken_ scope = do
 --
 -- > request $ do
 -- >   addToken
-addToken :: HasCallStack => RequestBuilder site ()
+addToken :: RequestBuilder site ()
 addToken = addToken_ ""
 
 -- | Calls 'addTokenFromCookieNamedToHeaderNamed' with the 'defaultCsrfCookieName' and 'defaultCsrfHeaderName'.
@@ -1235,7 +1159,7 @@ addToken = addToken_ ""
 -- >   addTokenFromCookie
 --
 -- Since 1.4.3.2
-addTokenFromCookie :: HasCallStack => RequestBuilder site ()
+addTokenFromCookie :: RequestBuilder site ()
 addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName defaultCsrfHeaderName
 
 -- | Looks up the CSRF token stored in the cookie with the given name and adds it to the request headers. An error is thrown if the cookie can't be found.
@@ -1251,8 +1175,7 @@ addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName
 -- >   addTokenFromCookieNamedToHeaderNamed "cookieName" (CI "headerName")
 --
 -- Since 1.4.3.2
-addTokenFromCookieNamedToHeaderNamed :: HasCallStack
+addTokenFromCookieNamedToHeaderNamed :: ByteString -- ^ The name of the cookie
-                                     => ByteString -- ^ The name of the cookie
                                      -> CI ByteString -- ^ The name of the header
                                      -> RequestBuilder site ()
 addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
@@ -1275,7 +1198,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
 -- >   liftIO $ putStrLn $ "Cookies are: " ++ show cookies
 --
 -- Since 1.4.3.2
-getRequestCookies :: HasCallStack => RequestBuilder site Cookies
+getRequestCookies :: RequestBuilder site Cookies
 getRequestCookies = do
   requestBuilderData <- getSIO
   headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
@@ -1437,7 +1360,7 @@ setUrl url' = do
 -- > clickOn "a#idofthelink"
 --
 -- @since 1.5.7 
-clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site ()
+clickOn :: Yesod site => Query -> YesodExample site ()
 clickOn query = do
   withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res ->
     case findAttributeBySelector (simpleBody res) query "href" of
@@ -1641,7 +1564,7 @@ parseSetCookies :: [H.Header] -> [Cookie.SetCookie]
 parseSetCookies headers = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ headers
 
 -- Yes, just a shortcut
-failure :: (HasCallStack, MonadIO a) => T.Text -> a b
+failure :: (MonadIO a) => T.Text -> a b
 failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error ""
 
 type TestApp site = (site, Middleware)
@@ -1665,3 +1588,27 @@ instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) whe
                 return ())
             params
             ($ ())
+
+-- | State + IO
+--
+-- @since 1.6.0
+newtype SIO s a = SIO (ReaderT (IORef s) IO a)
+  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
+
+getSIO :: SIO s s
+getSIO = SIO $ ReaderT readIORef
+
+putSIO :: s -> SIO s ()
+putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
+
+modifySIO :: (s -> s) -> SIO s ()
+modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
+
+evalSIO :: SIO s a -> s -> IO a
+evalSIO (SIO (ReaderT f)) s = newIORef s >>= f
+
+execSIO :: SIO s () -> s -> IO s
+execSIO (SIO (ReaderT f)) s = do
+  ref <- newIORef s
+  f ref
+  readIORef ref

yesod-test/Yesod/Test/Internal.hs

@@ -1,65 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
--- | This module exposes functions that are used internally by yesod-test.
--- The functions exposed here are _not_ a stable API—they may be changed or removed without any major version bump.
---
--- That said, you may find them useful if your application can accept API breakage.
-module Yesod.Test.Internal
-  ( getBodyTextPreview
-  , contentTypeHeaderIsUtf8
-  , assumedUTF8ContentTypes
-  ) where
-
-import qualified Data.ByteString.Char8 as BS8
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Encoding as DTLE
-import qualified Yesod.Core.Content as Content
-import Data.Semigroup (Semigroup(..))
-
--- | Helper function to get the first 1024 characters of the body, assuming it is UTF-8.
--- This function is used to preview the body in case of an assertion failure.
---
--- @since 1.6.10
-getBodyTextPreview :: LBS.ByteString -> T.Text
-getBodyTextPreview body =
-  let characterLimit = 1024
-      textBody = TL.toStrict $ DTLE.decodeUtf8 body
-  in if T.length textBody < characterLimit
-        then textBody
-        else T.take characterLimit textBody <> "... (use `printBody` to see complete response body)"
-
--- | Helper function to determine if we can print a body as plain text, for debugging purposes.
---
--- @since 1.6.10
-contentTypeHeaderIsUtf8 :: BS8.ByteString -> Bool
-contentTypeHeaderIsUtf8 contentTypeBS =
-      -- Convert to Text, so we can use T.splitOn
-  let contentTypeText = T.toLower $ TE.decodeUtf8 contentTypeBS
-      isUTF8FromCharset = case T.splitOn "charset=" contentTypeText of
-        -- Either a specific designation as UTF-8, or ASCII (which is a subset of UTF-8)
-        [_, charSet] -> any (`T.isInfixOf` charSet) ["utf-8", "us-ascii"]
-        _ -> False
-
-      isInferredUTF8FromContentType = BS8.takeWhile (/= ';') contentTypeBS `Set.member` assumedUTF8ContentTypes
-
-  in isUTF8FromCharset || isInferredUTF8FromContentType
-
--- | List of Content-Types that are assumed to be UTF-8 (e.g. JSON).
---
--- @since 1.6.10
-assumedUTF8ContentTypes :: Set.Set BS8.ByteString
-assumedUTF8ContentTypes = Set.fromList $ map Content.simpleContentType
-  [ Content.typeHtml
-  , Content.typePlain
-  , Content.typeJson
-  , Content.typeXml
-  , Content.typeAtom
-  , Content.typeRss
-  , Content.typeSvg
-  , Content.typeJavascript
-  , Content.typeCss
-  ]

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

@@ -1,88 +0,0 @@
-{-# 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)