debug: fix traceStack call

.envrc

@@ -0,0 +1 @@
+use flake

.github/workflows/tests.yml

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

.gitignore

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

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

flake.lock

@@ -0,0 +1,44 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "locked": {
+        "lastModified": 1619345332,
+        "narHash": "sha256-qHnQkEp1uklKTpx3MvKtY6xzgcqXDsz5nLilbbuL+3A=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "2ebf2558e5bf978c7fb8ea927dfaed8fefab2e28",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "ref": "master",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1620323686,
+        "narHash": "sha256-+gfcE3YTGl+Osc8HzOUXSFO8/0PAK4J8ZxCXZ4hjXHI=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "dfacb8329b2236688b9a1e705116203a213b283a",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "master",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,30 @@
+{
+  inputs = {
+    nixpkgs = {
+      type = "github";
+      owner = "NixOS";
+      repo = "nixpkgs";
+      ref = "master";
+    };
+    flake-utils = {
+      type = "github";
+      owner = "numtide";
+      repo = "flake-utils";
+      ref = "master";
+    };
+  };
+
+  outputs = { self, nixpkgs, flake-utils, ... }: flake-utils.lib.eachDefaultSystem
+    (system:
+      let pkgs = import nixpkgs {
+            inherit system;
+            config.allowUnfree = true;
+          };
+      in {
+        devShell = pkgs.mkShell {
+          name = "uni2work-yesod";
+          nativeBuildInputs = with pkgs.haskellPackages; [ stack ];
+        };
+      }
+    );
+}

nixpkgs.nix

@@ -0,0 +1,8 @@
+import (
+  let
+    lock = builtins.fromJSON (builtins.readFile ./flake.lock);
+  in fetchTarball {
+    url = "https://api.github.com/repos/NixOS/nixpkgs/tarball/${lock.nodes.nixpkgs.locked.rev}";
+    sha256 = lock.nodes.nixpkgs.locked.narHash;
+  }
+)

stack-persistent-211.yaml

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

stack-persistent-212.yaml

@@ -0,0 +1,20 @@
+resolver: nightly-2021-03-31
+packages:
+- ./yesod-core
+- ./yesod-static
+- ./yesod-persistent
+- ./yesod-newsfeed
+- ./yesod-form
+- ./yesod-form-multi
+- ./yesod-auth
+- ./yesod-auth-oauth
+- ./yesod-sitemap
+- ./yesod-test
+- ./yesod-bin
+- ./yesod
+- ./yesod-eventsource
+- ./yesod-websockets
+extra-deps:
+- persistent-2.12.0.1
+- persistent-template-2.12.0.0
+- persistent-sqlite-2.12.0.0

stack-persistent-213.yaml

@@ -0,0 +1,23 @@
+resolver: nightly-2021-03-31
+packages:
+- ./yesod-core
+- ./yesod-static
+- ./yesod-persistent
+- ./yesod-newsfeed
+- ./yesod-form
+- ./yesod-form-multi
+- ./yesod-auth
+- ./yesod-auth-oauth
+- ./yesod-sitemap
+- ./yesod-test
+- ./yesod-bin
+- ./yesod
+- ./yesod-eventsource
+- ./yesod-websockets
+extra-deps:
+- lift-type-0.1.0.1
+- persistent-2.13.0.0
+- persistent-mysql-2.13.0.0
+- persistent-sqlite-2.13.0.0
+- persistent-postgresql-2.13.0.0
+- persistent-template-2.12.0.0

stack.nix

@@ -0,0 +1,14 @@
+{ ghc, nixpkgs ? import ./nixpkgs.nix }:
+
+let
+  # haskellPackages = import ./stackage.nix { inherit nixpkgs; };
+  haskellPackages = pkgs.haskellPackages;
+  inherit (nixpkgs {}) pkgs;
+in pkgs.haskell.lib.buildStackProject {
+  inherit ghc;
+  inherit (haskellPackages) stack;
+  name = "stackenv";
+  buildInputs = with pkgs;
+    [ zlib
+    ];
+}

stack.yaml

@@ -1,4 +1,10 @@
-resolver: lts-18.3
+nix:
+  packages: []
+  pure: false
+  shell-file: ./stack.nix
+  add-gc-roots: true
+
+resolver: lts-16.31
 packages:
 - ./yesod-core
 - ./yesod-static
@@ -14,6 +20,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: 534126
-    size: 585603
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/3.yaml
+    sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6
-  original: lts-18.3
+  original: lts-16.31

yesod-auth-oauth/ChangeLog.md

@@ -1,9 +1,5 @@
 # ChangeLog for yesod-auth-oauth
 
-## 1.6.1
-
-* Allow newer GHC
-
 ## 1.6.0.3
 
 * Allow yesod-form 1.7

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,6 @@
 cabal-version:   >= 1.10
 name:            yesod-auth-oauth
-version:         1.6.1
+version:         1.6.0.3
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
@@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md
 
 library
     default-language: Haskell2010
-    build-depends:   authenticate-oauth      >= 1.5       && < 1.8
+    build-depends:   authenticate-oauth      >= 1.5       && < 1.7
                    , base                    >= 4.10      && < 5
                    , bytestring              >= 0.9.1.4
                    , text                    >= 0.7

yesod-auth/ChangeLog.md

@@ -1,25 +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

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
@@ -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
@@ -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'.
@@ -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,6 @@
 cabal-version:   >=1.10
 name:            yesod-auth
-version:         1.6.11.2
+version:         1.6.10.3
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -23,7 +23,6 @@ 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

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)
@@ -252,8 +247,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,17 +1,5 @@
 # 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)

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

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/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.6.2.2
+version:         1.6.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -35,7 +35,7 @@ executable             yesod
                      , directory          >= 1.2.1
                      , file-embed
                      , filepath           >= 1.1
-                     , fsnotify
+                     , fsnotify           >= 0.0          && < 0.4
                      , http-client        >= 0.4.7
                      , http-client-tls
                      , http-reverse-proxy >= 0.4
@@ -61,7 +61,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,64 +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)

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
@@ -555,9 +539,8 @@ widgetToPageContent w = do
     { 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 (..)
@@ -111,8 +100,6 @@ toWaiAppPlain site = do
 -- 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
   where
@@ -197,16 +184,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

@@ -245,7 +245,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 +261,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
@@ -1150,9 +1149,9 @@ cached action = do
     eres <- Cache.cached cache action
     case eres of
       Right res -> return res
-      Left (newCache, res) -> do
+      Left (updateCache, res) -> do
           gs <- get
-          let merged = newCache `HM.union` ghsCache gs
+          let merged = updateCache $ ghsCache gs
           put $ gs { ghsCache = merged }
           return res
 
@@ -1193,9 +1192,9 @@ cachedBy k action = do
     eres <- Cache.cachedBy cache k action
     case eres of
       Right res -> return res
-      Left (newCache, res) -> do
+      Left (updateCache, res) -> do
           gs <- get
-          let merged = newCache `HM.union` ghsCacheBy gs
+          let merged = updateCache $ ghsCacheBy gs
           put $ gs { ghsCacheBy = merged }
           return res
 

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,8 @@ import           Yesod.Core.Internal.Util     (getCurrentMaxExpiresRFC1123)
 import           Yesod.Routes.Class           (Route, renderRoute)
 import           Control.DeepSeq              (($!!), NFData)
 import           UnliftIO.Exception
-import           UnliftIO(MonadUnliftIO, withRunInIO)
+
-import           Data.Proxy(Proxy(..))
+import Debug.Trace (traceStack)
 
 -- | Convert a synchronous exception into an ErrorResponse
 toErrorHandler :: SomeException -> IO ErrorResponse
@@ -88,7 +73,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,14 +174,11 @@ 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)
 
@@ -212,8 +194,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
@@ -227,7 +209,8 @@ safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
        -> ErrorResponse
        -> YesodApp
 safeEh log' er req = do
-    liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError
+    traceStack "safeEh debug trace:" $ liftIO
+           $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError
            $ toLogStr $ "Error handler errored out: " ++ show er
     return $ YRPlain
         H.status500
@@ -256,7 +239,7 @@ safeEh log' er req = do
 -- @HandlerFor@ is completely ignored, including changes to the
 -- session, cookies or headers.  We only return you the
 -- @HandlerFor@'s return value.
-runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
+runFakeHandler :: (Yesod site, MonadIO m) =>
                   SessionMap
                -> (site -> Logger)
                -> site
@@ -277,7 +260,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 +301,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 +336,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,17 +100,9 @@ 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?
@@ -196,7 +113,6 @@ masterTypeSyns vs site =
       $ 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'
@@ -245,7 +148,7 @@ mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
         -- Base type (site type with variables)
     let site = foldl' AppT (ConT name) argtypes
         res = map (fmap (parseType . dropBracket)) resS
-    renderRouteDec <- 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
@@ -264,11 +167,18 @@ mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do
             ]
     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 +199,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 +219,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/TypeCache.hs

@@ -32,12 +32,12 @@ type KeyedTypeMap = HashMap (TypeRep, ByteString) Dynamic
 cached :: (Monad m, Typeable a)
        => TypeMap
        -> m a                       -- ^ cache the result of this action
-       -> m (Either (TypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
+       -> m (Either (TypeMap -> TypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
 cached cache action = case cacheGet cache of
     Just val -> return $ Right val
     Nothing -> do
         val <- action
-        return $ Left (cacheSet val cache, val)
+        return $ Left (cacheSet val, val)
 
 -- | Retrieves a value from the cache
 --
@@ -72,12 +72,12 @@ cachedBy :: (Monad m, Typeable a)
          => KeyedTypeMap
          -> ByteString                     -- ^ a cache key
          -> m a                            -- ^ cache the result of this action
-         -> m (Either (KeyedTypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
+         -> m (Either (KeyedTypeMap -> KeyedTypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
 cachedBy cache k action = case cacheByGet k cache of
     Just val -> return $ Right val
     Nothing -> do
         val <- action
-        return $ Left (cacheBySet k val cache, val)
+        return $ Left (cacheBySet k val, val)
 
 -- | Retrieves a value from the keyed cache
 --

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
@@ -295,10 +289,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.
@@ -394,7 +387,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 +402,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 +409,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

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,48 +220,6 @@ 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
@@ -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/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/YesodCoreTest.hs

@@ -5,11 +5,9 @@ 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
@@ -44,7 +42,6 @@ specs = do
       mediaTest
       linksTest
       noOverloadedTest
-      subSubTest
       internalRequestTest
       errorHandlingTest
       cacheTest
@@ -66,4 +63,3 @@ specs = do
       Ssl.sameSiteSpec
       Csrf.csrfSpec
       breadcrumbTest
-      metaTest

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/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/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.25.1
+version:         1.6.20.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -27,7 +27,6 @@ library
 
     build-depends:   base                  >= 4.10     && < 5
                    , aeson                 >= 1.0
-                   , attoparsec-aeson      >= 2.1
                    , auto-update
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.7.1
@@ -59,7 +58,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
@@ -147,7 +146,6 @@ test-suite tests
                    YesodCoreTest.Header
                    YesodCoreTest.Csrf
                    YesodCoreTest.ErrorHandling
-                   YesodCoreTest.ErrorHandling.CustomApp
                    YesodCoreTest.Exceptions
                    YesodCoreTest.InternalRequest
                    YesodCoreTest.JsLoader
@@ -157,7 +155,6 @@ test-suite tests
                    YesodCoreTest.LiteApp
                    YesodCoreTest.Media
                    YesodCoreTest.MediaData
-                   YesodCoreTest.Meta
                    YesodCoreTest.NoOverloadedStrings
                    YesodCoreTest.NoOverloadedStringsSub
                    YesodCoreTest.ParameterizedSite
@@ -174,8 +171,6 @@ test-suite tests
                    YesodCoreTest.StubSslOnly
                    YesodCoreTest.StubStrictSameSite
                    YesodCoreTest.StubUnsecured
-                   YesodCoreTest.SubSub
-                   YesodCoreTest.SubSubData
                    YesodCoreTest.WaiSubsite
                    YesodCoreTest.Widget
                    YesodCoreTest.YesodTest

yesod-form/ChangeLog.md

@@ -1,29 +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)

yesod-form/Yesod/Form/Fields.hs

@@ -49,7 +49,6 @@ module Yesod.Form.Fields
     , selectFieldListGrouped
     , radioField
     , radioFieldList
-    , withRadioField
     , checkboxesField
     , checkboxesFieldList
     , multiSelectField
@@ -63,8 +62,6 @@ module Yesod.Form.Fields
     , optionsPairs
     , optionsPairsGrouped
     , optionsEnum
-    , colorField
-    , datetimeLocalField
     ) where
 
 import Yesod.Form.Types
@@ -75,7 +72,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)
@@ -99,8 +96,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 +117,6 @@ import Data.String (IsString)
 import Data.Monoid
 #endif
 
-import Data.Char (isHexDigit)
-
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
 
@@ -533,52 +527,26 @@ 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>
+|])
-|]
+     Nothing
-    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.
 --
@@ -980,44 +948,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,6 @@
 cabal-version:   >= 1.10
 name:            yesod-form
-version:         1.7.6
+version:         1.7.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -10,7 +10,7 @@ category:        Web, Yesod
 stability:       Stable
 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
 
@@ -67,7 +67,6 @@ library
                      Yesod.Form.I18n.Spanish
                      Yesod.Form.I18n.Chinese
                      Yesod.Form.I18n.Korean
-                     Yesod.Form.I18n.Romanian
                      -- FIXME Yesod.Helpers.Crud
     ghc-options:     -Wall
 

yesod-persistent/ChangeLog.md

@@ -1,9 +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)

yesod-persistent/Yesod/Persist/Core.hs

@@ -37,9 +37,6 @@ 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,21 +187,14 @@ 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
@@ -224,12 +214,7 @@ insert400 datum = do
 -- | 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/yesod-persistent.cabal

@@ -1,6 +1,6 @@
 cabal-version:   >= 1.10
 name:            yesod-persistent
-version:         1.6.0.8
+version:         1.6.0.7
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -34,7 +34,6 @@ test-suite test
     main-is: Spec.hs
     hs-source-dirs: test
     other-modules: Yesod.PersistSpec
-    build-tool-depends: hspec-discover:hspec-discover
     build-depends: base
                  , hspec
                  , wai-extra

yesod-test/ChangeLog.md

@@ -1,24 +1,5 @@
 # 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)

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

@@ -152,7 +152,6 @@ module Yesod.Test
     , setMethod
     , addPostParam
     , addGetParam
-    , addBareGetParam
     , addFile
     , setRequestBody
     , RequestBuilder
@@ -171,7 +170,6 @@ module Yesod.Test
     , byLabelContain
     , byLabelPrefix
     , byLabelSuffix
-    , bySelectorLabelContain
     , fileByLabel
     , fileByLabelExact
     , fileByLabelContain
@@ -243,11 +241,12 @@ 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 qualified Control.Monad.State.Class as MS
 import System.IO
 import Yesod.Core.Unsafe (runFakeHandler)
 import Yesod.Test.TransversingCSS
@@ -258,6 +257,7 @@ 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
@@ -281,7 +281,6 @@ 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" #-}
@@ -548,8 +547,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.
 --
@@ -710,13 +711,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 +729,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 +746,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"
@@ -850,23 +846,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.
@@ -895,36 +874,9 @@ genericNameFromLabel match label = do
     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 +885,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 +914,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 +1027,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.
@@ -1665,3 +1596,32 @@ 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)
+
+instance MS.MonadState s (SIO s)
+  where
+  get = getSIO
+  put = putSIO
+
+getSIO :: SIO s s
+getSIO = SIO $ ReaderT readIORef
+
+putSIO :: s -> SIO s ()
+putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
+
+modifySIO :: (s -> s) -> SIO s ()
+modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
+
+evalSIO :: SIO s a -> s -> IO a
+evalSIO (SIO (ReaderT f)) s = newIORef s >>= f
+
+execSIO :: SIO s () -> s -> IO s
+execSIO (SIO (ReaderT f)) s = do
+  ref <- newIORef s
+  f ref
+  readIORef ref

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

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

yesod-test/test/main.hs

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

yesod-test/yesod-test.cabal

@@ -1,5 +1,5 @@
 name:               yesod-test
-version:            1.6.16
+version:            1.6.12
 license:            MIT
 license-file:       LICENSE
 author:             Nubis <nubis@woobiz.com.ar>
@@ -41,13 +41,11 @@ library
                    , xml-conduit               >= 1.0
                    , xml-types                 >= 0.3
                    , yesod-core                >= 1.6.17
-                   , blaze-markup
 
     exposed-modules: Yesod.Test
                      Yesod.Test.CssQuery
                      Yesod.Test.TransversingCSS
                      Yesod.Test.Internal
-                     Yesod.Test.Internal.SIO
     ghc-options:  -Wall
 
 test-suite test

yesod-websockets/ChangeLog.md

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

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

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

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

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

yesod-websockets/chat.hs

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

yesod-websockets/yesod-websockets.cabal

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

yesod/ChangeLog.md

@@ -1,17 +1,5 @@
 # ChangeLog for yesod
 
-## 1.6.2.1
-
-* Support `template-haskell-2.19.0.0` [#1769](https://github.com/yesodweb/yesod/pull/1769)
-
-## 1.6.2
-
-* aeson 2
-
-## 1.6.1.2
-
-* Fix compatibility with template-haskell 2.17 [#1730](https://github.com/yesodweb/yesod/pull/1730)
-
 ## 1.6.1.1
 
 * Allow yesod-form 1.7

yesod/Yesod/Default/Config.hs

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

yesod/Yesod/Default/Config2.hs

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

yesod/Yesod/Default/Util.hs

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

yesod/yesod.cabal

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