From 189487914d894cd70d587b49e859ccc7a48c3c67 Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Wed, 30 Jun 2021 18:07:24 +0800 Subject: [PATCH 001/113] Fix compatibility with template-haskell 2.17 for yesod --- yesod/Yesod/Default/Util.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod/Yesod/Default/Util.hs b/yesod/Yesod/Default/Util.hs index e0d6ae1a..20514139 100644 --- a/yesod/Yesod/Default/Util.hs +++ b/yesod/Yesod/Default/Util.hs @@ -113,7 +113,11 @@ combine func file isReload tls = do , show file , ", but no templates were found." ] +#if MIN_VERSION_template_haskell(2,17,0) + exps -> return $ DoE Nothing $ map NoBindS exps +#else exps -> return $ DoE $ map NoBindS exps +#endif where qmexps :: Q [Maybe Exp] qmexps = mapM go tls From 44b1ea252c421b6ae1db6bb3c4deae5719161c19 Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Wed, 30 Jun 2021 18:11:33 +0800 Subject: [PATCH 002/113] Bump version and update Changelog --- yesod/ChangeLog.md | 4 ++++ yesod/yesod.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod/ChangeLog.md b/yesod/ChangeLog.md index dd2fe0b0..4929bf12 100644 --- a/yesod/ChangeLog.md +++ b/yesod/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod +## 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 diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 2b0ef5b8..4da584e1 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 1.6.1.1 +version: 1.6.1.2 license: MIT license-file: LICENSE author: Michael Snoyman From e972a63a35d9b2bb3e9919ff74adfe7bc7e3ffda Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Thu, 8 Jul 2021 17:51:58 +0800 Subject: [PATCH 003/113] Correct a typo in yesod-form's description --- yesod-form/yesod-form.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index dc33cbf0..5ef05965 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -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 . Third-party packages which you can find useful: - richtext form fields (currntly it provides only Summernote support). +description: API docs and the README are available at . Third-party packages which you can find useful: - richtext form fields (currently it provides only Summernote support). extra-source-files: ChangeLog.md README.md From 1f52a39aa2c4ad188b07fc167c38fe4eb68323f3 Mon Sep 17 00:00:00 2001 From: Georgi Lyubenov Date: Thu, 22 Jul 2021 14:52:48 +0300 Subject: [PATCH 004/113] Export defaultGen --- yesod-core/ChangeLog.md | 4 ++++ yesod-core/src/Yesod/Core/Dispatch.hs | 3 +++ yesod-core/yesod-core.cabal | 2 +- 3 files changed, 8 insertions(+), 1 deletion(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 7fb76193..ef7e258a 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-core +## 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) diff --git a/yesod-core/src/Yesod/Core/Dispatch.hs b/yesod-core/src/Yesod/Core/Dispatch.hs index 8a2501e6..feb7765b 100644 --- a/yesod-core/src/Yesod/Core/Dispatch.hs +++ b/yesod-core/src/Yesod/Core/Dispatch.hs @@ -17,6 +17,7 @@ module Yesod.Core.Dispatch , mkYesodDispatch , mkYesodSubDispatch -- *** Helpers + , defaultGen , getGetMaxExpires -- ** Path pieces , PathPiece (..) @@ -100,6 +101,8 @@ 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 diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 0e3799d5..f01e5ff9 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.20.2 +version: 1.6.21.0 license: MIT license-file: LICENSE author: Michael Snoyman From 58311a3d9309ef2439bd425a9a8206b3dddb95af Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 22 Jul 2021 18:06:37 +0300 Subject: [PATCH 005/113] Simplify matrix, disable nightly --- .github/workflows/tests.yml | 20 +++++++------------- stack-persistent-211.yaml | 20 -------------------- stack-persistent-212.yaml | 20 -------------------- stack-persistent-213.yaml | 23 ----------------------- stack.yaml | 2 +- stack.yaml.lock | 8 ++++---- 6 files changed, 12 insertions(+), 81 deletions(-) delete mode 100644 stack-persistent-211.yaml delete mode 100644 stack-persistent-212.yaml delete mode 100644 stack-persistent-213.yaml diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index c328b031..239c9732 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -15,24 +15,16 @@ jobs: matrix: os: [ubuntu-latest, macos-latest, windows-latest] args: - - "--resolver nightly" + #- "--resolver nightly" + - "--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: windows-latest - args: "--resolver lts-16" - - os: windows-latest - args: "--stack-yaml stack-persistent-211.yaml" - - os: windows-latest - args: "--stack-yaml stack-persistent-212.yaml" steps: - name: Clone project @@ -51,6 +43,8 @@ jobs: shell: bash run: | set -ex - stack upgrade - stack --version - stack test --fast --no-terminal ${{ matrix.args }} + mkdir -p ../_newstack + stack upgrade --force-download --local-bin-path ../_newstack + ../_newstack/stack --version + ../_newstack/stack + ../_newstack/stack test --fast --no-terminal ${{ matrix.args }} diff --git a/stack-persistent-211.yaml b/stack-persistent-211.yaml deleted file mode 100644 index 883223ba..00000000 --- a/stack-persistent-211.yaml +++ /dev/null @@ -1,20 +0,0 @@ -resolver: lts-16.20 -packages: -- ./yesod-core -- ./yesod-static -- ./yesod-persistent -- ./yesod-newsfeed -- ./yesod-form -- ./yesod-form-multi -- ./yesod-auth -- ./yesod-auth-oauth -- ./yesod-sitemap -- ./yesod-test -- ./yesod-bin -- ./yesod -- ./yesod-eventsource -- ./yesod-websockets -extra-deps: -- persistent-2.11.0.1@rev:0 -- persistent-template-2.9.1.0@rev:0 -- persistent-sqlite-2.11.0.0@rev:0 diff --git a/stack-persistent-212.yaml b/stack-persistent-212.yaml deleted file mode 100644 index b4087765..00000000 --- a/stack-persistent-212.yaml +++ /dev/null @@ -1,20 +0,0 @@ -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 diff --git a/stack-persistent-213.yaml b/stack-persistent-213.yaml deleted file mode 100644 index c90d12e7..00000000 --- a/stack-persistent-213.yaml +++ /dev/null @@ -1,23 +0,0 @@ -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 diff --git a/stack.yaml b/stack.yaml index 3aed69da..8078abab 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-15.5 +resolver: lts-18.3 packages: - ./yesod-core - ./yesod-static diff --git a/stack.yaml.lock b/stack.yaml.lock index b90ed2d5..7940767f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 491372 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/5.yaml - sha256: 1b549cfff328040c382a70a84a2087aac8dab6d778bf92f32a93a771a1980dfc - original: lts-15.5 + size: 585603 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/3.yaml + sha256: 694573e96dca34db5636edb1fe6c96bb233ca0f9fb96c1ead1671cdfa9bd73e9 + original: lts-18.3 From 8f83462134d260b59a156ab8fc43ab26f0b906b5 Mon Sep 17 00:00:00 2001 From: Arthur Sakhievich Fayzrakhmanov Date: Fri, 10 Sep 2021 11:29:24 +0500 Subject: [PATCH 006/113] Fix GHC 9.0.1 build --- yesod-auth/Yesod/Auth/Dummy.hs | 2 ++ yesod-auth/Yesod/Auth/Email.hs | 26 ++++++++++++++------------ yesod-auth/Yesod/Auth/GoogleEmail2.hs | 4 +++- yesod-auth/Yesod/Auth/Hardcoded.hs | 1 + 4 files changed, 20 insertions(+), 13 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Dummy.hs b/yesod-auth/Yesod/Auth/Dummy.hs index b768b3ae..5b1b703c 100644 --- a/yesod-auth/Yesod/Auth/Dummy.hs +++ b/yesod-auth/Yesod/Auth/Dummy.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Provides a dummy authentication module that simply lets a user specify -- their identifier. This is not intended for real world use, just for @@ -49,6 +50,7 @@ authDummy :: YesodAuth m => AuthPlugin m authDummy = AuthPlugin "dummy" dispatch login where + dispatch :: Text -> [Text] -> AuthHandler m TypedContent dispatch "POST" [] = do (jsonResult :: Result Value) <- parseCheckJsonBody eIdent <- case jsonResult of diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 7a09d8c6..2395ed67 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -31,16 +31,16 @@ -- = Using JSON Endpoints -- -- We are assuming that you have declared auth route as follows --- +-- -- @ -- /auth AuthR Auth getAuth -- @ --- +-- -- If you are using a different route, then you have to adjust the -- endpoints accordingly. -- -- * Registration --- +-- -- @ -- Endpoint: \/auth\/page\/email\/register -- Method: POST @@ -49,9 +49,9 @@ -- "password": "myStrongPassword" (optional) -- } -- @ --- +-- -- * Forgot password --- +-- -- @ -- Endpoint: \/auth\/page\/email\/forgot-password -- Method: POST @@ -59,16 +59,16 @@ -- @ -- -- * Login --- +-- -- @ -- Endpoint: \/auth\/page\/email\/login -- Method: POST --- JSON Data: { +-- JSON Data: { -- "email": "myemail@domain.com", -- "password": "myStrongPassword" -- } -- @ --- +-- -- * Set new password -- -- @ @@ -139,6 +139,7 @@ import qualified Text.Email.Validate import Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?)) import Data.Maybe (isJust) import Data.ByteArray (convert) +import Yesod.Core.Types (TypedContent(TypedContent)) loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] @@ -240,7 +241,7 @@ class ( YesodAuth site -- -- @since 1.4.20 hashAndSaltPassword :: Text -> AuthHandler site SaltedPass - hashAndSaltPassword = liftIO . saltPass + hashAndSaltPassword password = liftIO $ saltPass password -- | Verify a password matches the stored password for the given account. -- @@ -432,6 +433,7 @@ 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 @@ -779,8 +781,8 @@ getPasswordR = do maid <- maybeAuthId case maid of Nothing -> loginErrorMessageI LoginR Msg.BadSetPass - Just _ -> do - needOld <- maybe (return True) needOldPassword maid + Just aid -> do + needOld <- needOldPassword aid setPasswordHandler needOld -- | Default implementation of 'setPasswordHandler'. @@ -932,7 +934,7 @@ postPasswordR = do mr <- getMessageRender selectRep $ do - provideRep $ + provideRep $ fmap asHtml $ redirect $ afterPasswordRoute y provideJsonMessage (mr msgOk) diff --git a/yesod-auth/Yesod/Auth/GoogleEmail2.hs b/yesod-auth/Yesod/Auth/GoogleEmail2.hs index ce734a40..5dbbd6d1 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail2.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail2.hs @@ -247,7 +247,9 @@ authPlugin storeToken clientID clientSecret = -- User's access token is saved for further access to API when storeToken $ setSession accessTokenKey accessToken' - personValue <- makeHttpRequest =<< personValueRequest token + personValReq <- personValueRequest token + personValue <- makeHttpRequest personValReq + person <- case parseEither parseJSON personValue of Left e -> error e Right x -> return x diff --git a/yesod-auth/Yesod/Auth/Hardcoded.hs b/yesod-auth/Yesod/Auth/Hardcoded.hs index 4acfac06..e8bdccdb 100644 --- a/yesod-auth/Yesod/Auth/Hardcoded.hs +++ b/yesod-auth/Yesod/Auth/Hardcoded.hs @@ -159,6 +159,7 @@ 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 loginWidget toMaster = do From 814584d7d99e705a074450535423ba365b6dc73a Mon Sep 17 00:00:00 2001 From: Arthur Sakhievich Fayzrakhmanov Date: Fri, 10 Sep 2021 11:30:05 +0500 Subject: [PATCH 007/113] Apply stylish-haskell --- yesod-auth/Yesod/Auth/Dummy.hs | 20 ++--- yesod-auth/Yesod/Auth/Email.hs | 65 +++++++-------- yesod-auth/Yesod/Auth/GoogleEmail2.hs | 112 +++++++++++++------------- yesod-auth/Yesod/Auth/Hardcoded.hs | 7 +- 4 files changed, 102 insertions(+), 102 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Dummy.hs b/yesod-auth/Yesod/Auth/Dummy.hs index 5b1b703c..6c470f22 100644 --- a/yesod-auth/Yesod/Auth/Dummy.hs +++ b/yesod-auth/Yesod/Auth/Dummy.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | Provides a dummy authentication module that simply lets a user specify -- their identifier. This is not intended for real world use, just for -- testing. This plugin supports form submissions via JSON (since 1.6.8). @@ -36,12 +36,12 @@ module Yesod.Auth.Dummy ( authDummy ) where -import Yesod.Auth -import Yesod.Form (runInputPost, textField, ireq) -import Yesod.Core -import Data.Text (Text) -import Data.Aeson.Types (Result(..), Parser) +import Data.Aeson.Types (Parser, Result (..)) import qualified Data.Aeson.Types as A (parseEither, withObject) +import Data.Text (Text) +import Yesod.Auth +import Yesod.Core +import Yesod.Form (ireq, runInputPost, textField) identParser :: Value -> Parser Text identParser = A.withObject "Ident" (.: "ident") diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 2395ed67..5eceff35 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -117,29 +117,30 @@ module Yesod.Auth.Email , defaultRegisterHelper ) where -import Yesod.Auth -import qualified Yesod.Auth.Message as Msg -import Yesod.Core -import Yesod.Form -import qualified Yesod.Auth.Util.PasswordStore as PS -import Control.Applicative ((<$>), (<*>)) -import qualified Crypto.Hash as H -import qualified Crypto.Nonce as Nonce -import Data.ByteString.Base16 as B16 -import Data.Text (Text) -import qualified Data.Text as TS -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) -import qualified Data.Text.Encoding as TE -import Data.Text.Encoding.Error (lenientDecode) -import Data.Time (addUTCTime, getCurrentTime) -import Safe (readMay) -import System.IO.Unsafe (unsafePerformIO) +import Control.Applicative ((<$>), (<*>)) +import qualified Crypto.Hash as H +import qualified Crypto.Nonce as Nonce +import Data.Aeson.Types (Parser, Result (..), parseMaybe, + withObject, (.:?)) +import Data.ByteArray (convert) +import Data.ByteString.Base16 as B16 +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as TS +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import qualified Data.Text.Encoding as TE +import Data.Text.Encoding.Error (lenientDecode) +import Data.Time (addUTCTime, getCurrentTime) +import Safe (readMay) +import System.IO.Unsafe (unsafePerformIO) import qualified Text.Email.Validate -import Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?)) -import Data.Maybe (isJust) -import Data.ByteArray (convert) -import Yesod.Core.Types (TypedContent(TypedContent)) +import Yesod.Auth +import qualified Yesod.Auth.Message as Msg +import qualified Yesod.Auth.Util.PasswordStore as PS +import Yesod.Core +import Yesod.Core.Types (TypedContent (TypedContent)) +import Yesod.Form loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] @@ -440,7 +441,7 @@ authEmail = 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 @@ -578,7 +579,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do _ -> do (creds :: Result Value) <- parseCheckJsonBody return $ case creds of - Error _ -> Nothing + Error _ -> Nothing Success val -> parseMaybe parseRegister val let eidentifier = case creds of @@ -591,7 +592,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do let mpass = case (forgotPassword, creds) of (False, Just (_, mp)) -> mp - _ -> Nothing + _ -> Nothing case eidentifier of Left failMsg -> loginErrorMessageI dest failMsg @@ -622,7 +623,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do then sendConfirmationEmail creds else case emailPreviouslyRegisteredResponse identifier of Just response -> response - Nothing -> sendConfirmationEmail creds + Nothing -> sendConfirmationEmail creds where sendConfirmationEmail (lid, _, verKey, email) = do render <- getUrlRender tp <- getRouteToParent @@ -741,7 +742,7 @@ postLoginR = do _ -> do (creds :: Result Value) <- parseCheckJsonBody case creds of - Error _ -> return Nothing + Error _ -> return Nothing Success val -> return $ parseMaybe parseCreds val case midentifier of @@ -872,7 +873,7 @@ postPasswordR = do maid <- maybeAuthId (creds :: Result Value) <- parseCheckJsonBody let jcreds = case creds of - Error _ -> Nothing + Error _ -> Nothing Success val -> parseMaybe parsePassword val let doJsonParsing = isJust jcreds case maid of @@ -884,7 +885,7 @@ postPasswordR = do res <- runInputPostResult $ ireq textField "current" let fcurrent = case res of FormSuccess currentPass -> Just currentPass - _ -> Nothing + _ -> Nothing let current = if doJsonParsing then getThird jcreds else fcurrent @@ -903,9 +904,9 @@ postPasswordR = do where msgOk = Msg.PassUpdated getThird (Just (_,_,t)) = t - getThird Nothing = Nothing + getThird Nothing = Nothing getNewConfirm (Just (a,b,_)) = Just (a,b) - getNewConfirm _ = Nothing + getNewConfirm _ = Nothing confirmPassword aid tm jcreds = do res <- runInputPostResult $ (,) <$> ireq textField "new" @@ -914,7 +915,7 @@ postPasswordR = do then getNewConfirm jcreds else case res of FormSuccess res' -> Just res' - _ -> Nothing + _ -> Nothing case creds of Nothing -> loginErrorMessageI setpassR Msg.PassMismatch Just (new, confirm) -> diff --git a/yesod-auth/Yesod/Auth/GoogleEmail2.hs b/yesod-auth/Yesod/Auth/GoogleEmail2.hs index 5dbbd6d1..cf79a57f 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail2.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail2.hs @@ -53,55 +53,55 @@ module Yesod.Auth.GoogleEmail2 , pid ) where -import Yesod.Auth (Auth, AuthPlugin (AuthPlugin), - AuthRoute, Creds (Creds), - Route (PluginR), YesodAuth, - runHttpRequest, setCredsRedirect, - logoutDest, AuthHandler) -import qualified Yesod.Auth.Message as Msg -import Yesod.Core (HandlerSite, MonadHandler, - TypedContent, getRouteToParent, - getUrlRender, invalidArgs, - liftIO, lookupGetParam, - lookupSession, notFound, redirect, - setSession, whamlet, (.:), - addMessage, getYesod, - toHtml, liftSubHandler) +import Yesod.Auth (Auth, AuthHandler, + AuthPlugin (AuthPlugin), + AuthRoute, Creds (Creds), + Route (PluginR), YesodAuth, + logoutDest, runHttpRequest, + setCredsRedirect) +import qualified Yesod.Auth.Message as Msg +import Yesod.Core (HandlerSite, MonadHandler, + TypedContent, addMessage, + getRouteToParent, getUrlRender, + getYesod, invalidArgs, liftIO, + liftSubHandler, lookupGetParam, + lookupSession, notFound, redirect, + setSession, toHtml, whamlet, (.:)) -import Blaze.ByteString.Builder (fromByteString, toByteString) -import Control.Applicative ((<$>), (<*>)) -import Control.Arrow (second) -import Control.Monad (unless, when) -import Control.Monad.IO.Class (MonadIO) -import qualified Crypto.Nonce as Nonce -import Data.Aeson ((.:?)) -import qualified Data.Aeson as A +import Blaze.ByteString.Builder (fromByteString, toByteString) +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (second) +import Control.Monad (unless, when) +import Control.Monad.IO.Class (MonadIO) +import qualified Crypto.Nonce as Nonce +import Data.Aeson ((.:?)) +import qualified Data.Aeson as A #if MIN_VERSION_aeson(1,0,0) -import qualified Data.Aeson.Text as A +import qualified Data.Aeson.Text as A #else -import qualified Data.Aeson.Encode as A +import qualified Data.Aeson.Encode as A #endif -import Data.Aeson.Parser (json') -import Data.Aeson.Types (FromJSON (parseJSON), parseEither, - parseMaybe, withObject, withText) +import Data.Aeson.Parser (json') +import Data.Aeson.Types (FromJSON (parseJSON), parseEither, + parseMaybe, withObject, withText) import Data.Conduit -import Data.Conduit.Attoparsec (sinkParser) -import qualified Data.HashMap.Strict as M -import Data.Maybe (fromMaybe) -import Data.Monoid (mappend) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TL -import Network.HTTP.Client (Manager, requestHeaders, - responseBody, urlEncodedBody) -import qualified Network.HTTP.Client as HTTP +import Data.Conduit.Attoparsec (sinkParser) +import qualified Data.HashMap.Strict as M +import Data.Maybe (fromMaybe) +import Data.Monoid (mappend) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TL +import Network.HTTP.Client (Manager, requestHeaders, + responseBody, urlEncodedBody) +import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.Conduit (Request, bodyReaderSource) -import Network.HTTP.Conduit (http) -import Network.HTTP.Types (renderQueryText) -import System.IO.Unsafe (unsafePerformIO) +import Network.HTTP.Conduit (http) +import Network.HTTP.Types (renderQueryText) +import System.IO.Unsafe (unsafePerformIO) -- | Plugin identifier. This is used to identify the plugin used for @@ -239,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' @@ -251,14 +251,14 @@ authPlugin storeToken clientID clientSecret = personValue <- makeHttpRequest personValReq person <- case parseEither parseJSON personValue of - Left e -> error e + Left e -> error e Right x -> return x email <- case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of [e] -> return e - [] -> error "No account email" - x -> error $ "Too many account emails: " ++ show x + [] -> error "No account email" + x -> error $ "Too many account emails: " ++ show x setCredsRedirect $ Creds pid email $ allPersonInfo personValue dispatch _ _ = notFound @@ -452,16 +452,16 @@ data RelationshipStatus = Single -- ^ Person is single instance FromJSON RelationshipStatus where parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of - "single" -> Single - "in_a_relationship" -> InRelationship - "engaged" -> Engaged - "married" -> Married - "its_complicated" -> Complicated - "open_relationship" -> OpenRelationship - "widowed" -> Widowed - "in_domestic_partnership" -> DomesticPartnership - "in_civil_union" -> CivilUnion - _ -> RelationshipStatus t + "single" -> Single + "in_a_relationship" -> InRelationship + "engaged" -> Engaged + "married" -> Married + "its_complicated" -> Complicated + "open_relationship" -> OpenRelationship + "widowed" -> Widowed + "in_domestic_partnership" -> DomesticPartnership + "in_civil_union" -> CivilUnion + _ -> RelationshipStatus t -------------------------------------------------------------------------------- -- | The URI of the person's profile photo. diff --git a/yesod-auth/Yesod/Auth/Hardcoded.hs b/yesod-auth/Yesod/Auth/Hardcoded.hs index e8bdccdb..b700dbd4 100644 --- a/yesod-auth/Yesod/Auth/Hardcoded.hs +++ b/yesod-auth/Yesod/Auth/Hardcoded.hs @@ -131,10 +131,9 @@ module Yesod.Auth.Hardcoded , loginR ) where -import Yesod.Auth (AuthPlugin (..), AuthRoute, +import Yesod.Auth (AuthHandler, AuthPlugin (..), AuthRoute, Creds (..), Route (..), YesodAuth, - loginErrorMessageI, setCredsRedirect, - AuthHandler) + loginErrorMessageI, setCredsRedirect) import qualified Yesod.Auth.Message as Msg import Yesod.Core import Yesod.Form (ireq, runInputPost, textField) @@ -161,7 +160,7 @@ authHardcoded = where dispatch :: YesodAuthHardcoded m => Text -> [Text] -> AuthHandler m TypedContent dispatch "POST" ["login"] = postLoginR >>= sendResponse - dispatch _ _ = notFound + dispatch _ _ = notFound loginWidget toMaster = do request <- getRequest [whamlet| From 67f846d32493695f6bbf47dfaeea42ebe1e7afda Mon Sep 17 00:00:00 2001 From: Arthur Sakhievich Fayzrakhmanov Date: Fri, 10 Sep 2021 11:37:13 +0500 Subject: [PATCH 008/113] Version bump --- yesod-auth/yesod-auth.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 18d30a8c..f5aa0bce 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: yesod-auth -version: 1.6.10.3 +version: 1.6.10.4 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin From 1a6ba6d0992e6543da340e51130aed58f41a9ddd Mon Sep 17 00:00:00 2001 From: Arthur Sakhievich Fayzrakhmanov Date: Fri, 10 Sep 2021 13:35:15 +0500 Subject: [PATCH 009/113] Update Changelog --- yesod-auth/ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index df6b5ab2..782e12c1 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-auth +## 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 From 4ae578a1a11e0512acb3db8c1482ec96795ee715 Mon Sep 17 00:00:00 2001 From: Steve Mao Date: Wed, 29 Sep 2021 22:12:18 +1000 Subject: [PATCH 010/113] add multiple channels example --- .../chat-with-multiple-channels.hs | 122 ++++++++++++++++++ 1 file changed, 122 insertions(+) create mode 100644 yesod-websockets/chat-with-multiple-channels.hs diff --git a/yesod-websockets/chat-with-multiple-channels.hs b/yesod-websockets/chat-with-multiple-channels.hs new file mode 100644 index 00000000..8704d6f9 --- /dev/null +++ b/yesod-websockets/chat-with-multiple-channels.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} +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 + +data App = App (TVar (M.Map Text (TChan Text))) + +instance Yesod App + +mkYesod "App" [parseRoutes| +/ HomeR GET +|] + +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 channelMap + return chan + Just writeChan -> return writeChan + + readChan <- atomically $ do + writeTChan writeChan $ name <> " has joined the chat" + dupTChan writeChan + race_ + (forever $ atomically (readTChan readChan) >>= sendTextData) + (sourceWS $$ mapM_C (\msg -> + atomically $ writeTChan writeChan $ name <> ": " <> msg)) + +getHomeR :: Handler Html +getHomeR = do + webSockets chatApp + defaultLayout $ do + [whamlet| +
+
+ + |] + 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 From e6d27694080f2c3f6c491566d4a5eae2565d45c9 Mon Sep 17 00:00:00 2001 From: Steve Mao Date: Sat, 2 Oct 2021 17:22:58 +1000 Subject: [PATCH 011/113] update the examples to show how to cleanup resources once user disconnects --- .../chat-with-multiple-channels.hs | 30 +++++++++++++++---- yesod-websockets/chat-with-timeout-control.hs | 9 ++++-- yesod-websockets/chat.hs | 9 ++++-- 3 files changed, 39 insertions(+), 9 deletions(-) diff --git a/yesod-websockets/chat-with-multiple-channels.hs b/yesod-websockets/chat-with-multiple-channels.hs index 8704d6f9..9b1a23fd 100644 --- a/yesod-websockets/chat-with-multiple-channels.hs +++ b/yesod-websockets/chat-with-multiple-channels.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables #-} import Yesod.Core import Yesod.WebSockets import qualified Data.Text.Lazy as TL @@ -11,8 +11,9 @@ 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))) +data App = App (TVar (M.Map Text (TChan Text, Int))) instance Yesod App @@ -20,6 +21,15 @@ mkYesod "App" [parseRoutes| / HomeR GET |] +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) @@ -37,18 +47,28 @@ chatApp = do writeChan <- atomically $ case maybeChan of Nothing -> do chan <- newBroadcastTChan - writeTVar channelMapTVar $ M.insert channelId chan channelMap + writeTVar channelMapTVar $ M.insert channelId (chan, 1) channelMap return chan - Just writeChan -> return writeChan + Just (writeChan, _) -> do + writeTVar channelMapTVar $ M.alter userJoinedChannel channelId channelMap + return writeChan readChan <- atomically $ do writeTChan writeChan $ name <> " has joined the chat" dupTChan writeChan - race_ + (e :: Either SomeException ()) <- try $ race_ (forever $ atomically (readTChan readChan) >>= sendTextData) (sourceWS $$ mapM_C (\msg -> atomically $ writeTChan writeChan $ name <> ": " <> msg)) + atomically $ case e of + Left _ -> 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 diff --git a/yesod-websockets/chat-with-timeout-control.hs b/yesod-websockets/chat-with-timeout-control.hs index 00df99fc..7cf21860 100644 --- a/yesod-websockets/chat-with-timeout-control.hs +++ b/yesod-websockets/chat-with-timeout-control.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables #-} import Yesod.Core import Yesod.WebSockets import qualified Data.Text.Lazy as TL @@ -10,6 +10,7 @@ import Conduit import Data.Monoid ((<>)) import Control.Concurrent.STM.Lifted import Data.Text (Text) +import UnliftIO.Exception (try, SomeException) data App = App (TChan Text) @@ -28,11 +29,15 @@ chatApp = do readChan <- atomically $ do writeTChan writeChan $ name <> " has joined the chat" dupTChan writeChan - race_ + (e :: Either SomeException ()) <- try $ race_ (forever $ atomically (readTChan readChan) >>= sendTextData) (sourceWS $$ mapM_C (\msg -> atomically $ writeTChan writeChan $ name <> ": " <> msg)) + atomically $ case e of + Left _ -> writeTChan writeChan $ name <> " has left the chat" + Right () -> return () + getHomeR :: Handler Html getHomeR = do webSockets chatApp diff --git a/yesod-websockets/chat.hs b/yesod-websockets/chat.hs index 73f4df10..baddcf62 100644 --- a/yesod-websockets/chat.hs +++ b/yesod-websockets/chat.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables #-} import Yesod.Core import Yesod.WebSockets import qualified Data.Text.Lazy as TL @@ -10,6 +10,7 @@ import Conduit import Data.Monoid ((<>)) import Control.Concurrent.STM.Lifted import Data.Text (Text) +import UnliftIO.Exception (try, SomeException) data App = App (TChan Text) @@ -28,11 +29,15 @@ chatApp = do readChan <- atomically $ do writeTChan writeChan $ name <> " has joined the chat" dupTChan writeChan - race_ + (e :: Either SomeException ()) <- try $ race_ (forever $ atomically (readTChan readChan) >>= sendTextData) (sourceWS $$ mapM_C (\msg -> atomically $ writeTChan writeChan $ name <> ": " <> msg)) + atomically $ case e of + Left _ -> writeTChan writeChan $ name <> " has left the chat" + Right () -> return () + getHomeR :: Handler Html getHomeR = do webSockets chatApp From 3f0bf09712f64b21c582817ceac194903f9637c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jakob=20Sch=C3=B6ttl?= Date: Mon, 15 Nov 2021 10:25:30 +0100 Subject: [PATCH 012/113] Fix German translations of AuthMessage --- yesod-auth/Yesod/Auth/Message.hs | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Message.hs b/yesod-auth/Yesod/Auth/Message.hs index 9f41261a..45a75eea 100644 --- a/yesod-auth/Yesod/Auth/Message.hs +++ b/yesod-auth/Yesod/Auth/Message.hs @@ -282,13 +282,13 @@ germanMessage NoOpenID = "Kein OpenID-Identifier gefunden" germanMessage LoginOpenID = "Login via OpenID" germanMessage LoginGoogle = "Login via Google" germanMessage LoginYahoo = "Login via Yahoo" -germanMessage Email = "Email" -germanMessage UserName = "Benutzername" -- FIXME by Google Translate "user name" +germanMessage Email = "E-Mail" +germanMessage UserName = "Benutzername" germanMessage Password = "Passwort" germanMessage CurrentPassword = "Aktuelles Passwort" germanMessage Register = "Registrieren" germanMessage RegisterLong = "Neuen Account registrieren" -germanMessage EnterEmail = "Bitte die e-Mail Adresse angeben, eine Bestätigungsmail wird verschickt." +germanMessage EnterEmail = "Bitte die E-Mail Adresse angeben, eine Bestätigungsmail wird verschickt." germanMessage ConfirmationEmailSentTitle = "Bestätigung verschickt." germanMessage (ConfirmationEmailSent email) = "Eine Bestätigung wurde an " `mappend` @@ -308,24 +308,23 @@ germanMessage ConfirmPass = "Bestätigen" germanMessage PassMismatch = "Die Passwörter stimmen nicht überein" germanMessage PassUpdated = "Passwort überschrieben" germanMessage Facebook = "Login über Facebook" -germanMessage LoginViaEmail = "Login via e-Mail" +germanMessage LoginViaEmail = "Login via E-Mail" germanMessage InvalidLogin = "Ungültiger Login" germanMessage NowLoggedIn = "Login erfolgreich" -germanMessage LoginTitle = "Log In" +germanMessage LoginTitle = "Anmelden" germanMessage PleaseProvideUsername = "Bitte Nutzername angeben" germanMessage PleaseProvidePassword = "Bitte Passwort angeben" -germanMessage NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben" -germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter" +germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben" +germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter" germanMessage PasswordResetTitle = "Passwort zurücksetzen" -germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername" -germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen" -germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann." +germanMessage ProvideIdentifier = "E-Mail-Adresse oder Nutzername" +germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen" +germanMessage PasswordResetPrompt = "Nach Einhabe der E-Mail-Adresse oder des Nutzernamen wird eine E-Mail zugesendet mit welcher das Passwort zurückgesetzt werden kann." germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort" --- TODO -germanMessage i@(IdentifierNotFound _) = englishMessage i -germanMessage Logout = "Ausloggen" -- FIXME by Google Translate -germanMessage LogoutTitle = "Ausloggen" -- FIXME by Google Translate -germanMessage AuthError = "Autorisierungsfehler" -- FIXME by Google Translate +germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO +germanMessage Logout = "Abmelden" +germanMessage LogoutTitle = "Abmelden" +germanMessage AuthError = "Fehler beim Anmelden" frenchMessage :: AuthMessage -> Text frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé" From 072659b770f35526c6ac7679d92c761ddfcfa8ba Mon Sep 17 00:00:00 2001 From: smichel17 Date: Mon, 6 Dec 2021 18:13:09 +0000 Subject: [PATCH 013/113] Fix yesod-auth README link & add yesod-auth-oauth2 Fixes #1738 --- yesod-auth/README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/yesod-auth/README.md b/yesod-auth/README.md index e12c2e83..0eb153ce 100644 --- a/yesod-auth/README.md +++ b/yesod-auth/README.md @@ -6,6 +6,7 @@ BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available from Hackage as well. If you've written such an add-on, please notify me so that it can be added to this description. +* [yesod-auth-oauth2](https://hackage.haskell.org/package/yesod-auth-oauth2): Library to authenticate with OAuth 2.0. * [yesod-auth-account](http://hackage.haskell.org/package/yesod-auth-account): An account authentication plugin for Yesod * [yesod-auth-hashdb](http://www.stackage.org/package/yesod-auth-hashdb): The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security. -* [yesod-auth-bcrypt](https://github.com/ollieh/yesod-auth-bcrypt/): An alternative to the HashDB module. +* [yesod-auth-bcrypt](https://hackage.haskell.org/package/yesod-auth-bcrypt): An alternative to the HashDB module. From 6b164c60078811b6544ba126d4f0f40657bf4ff1 Mon Sep 17 00:00:00 2001 From: Steve Hart Date: Wed, 19 Jan 2022 10:18:12 -0500 Subject: [PATCH 014/113] Add missing documentation to 'warp' --- yesod-core/src/Yesod/Core/Dispatch.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/yesod-core/src/Yesod/Core/Dispatch.hs b/yesod-core/src/Yesod/Core/Dispatch.hs index feb7765b..c4cae401 100644 --- a/yesod-core/src/Yesod/Core/Dispatch.hs +++ b/yesod-core/src/Yesod/Core/Dispatch.hs @@ -187,6 +187,16 @@ toWaiAppLogger logger site = do -- middlewares. This set may change at any point without a breaking version -- number. Currently, it includes: -- +-- * Logging +-- +-- * GZIP compression +-- +-- * Automatic HEAD method handling +-- +-- * Request method override with the _method query string parameter +-- +-- * Accept header override with the _accept query string parameter +-- -- If you need more fine-grained control of middlewares, please use 'toWaiApp' -- directly. -- From ee41ae000eff056bcf4562f91e7bbf340084b412 Mon Sep 17 00:00:00 2001 From: Steve Hart Date: Wed, 19 Jan 2022 10:26:41 -0500 Subject: [PATCH 015/113] Update changelog --- yesod-core/ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index ef7e258a..47d63ffb 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-core +## Unreleased + +* Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745) + ## 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) From 863cdfa458cd0cc0517faa2fe4556394e00dc52c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Feb 2022 05:10:05 +0200 Subject: [PATCH 016/113] Enable a new nightly --- .github/workflows/tests.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index 239c9732..9833daa2 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -16,6 +16,7 @@ jobs: os: [ubuntu-latest, macos-latest, windows-latest] args: #- "--resolver nightly" + - "--resolver nightly-2022-02-11" - "--resolver lts-18" - "--resolver lts-16" - "--resolver lts-14" From 2c498c14b2aebbd59cb4e12b01e599104fb975ce Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Feb 2022 05:10:14 +0200 Subject: [PATCH 017/113] Relax an upper bound --- yesod-auth-oauth/yesod-auth-oauth.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index 4d0faa5e..a8969623 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md library default-language: Haskell2010 - build-depends: authenticate-oauth >= 1.5 && < 1.7 + build-depends: authenticate-oauth >= 1.5 && < 1.8 , base >= 4.10 && < 5 , bytestring >= 0.9.1.4 , text >= 0.7 From 385d17dd9410ea16e81003adefbfcb7828f33d41 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Feb 2022 05:28:01 +0200 Subject: [PATCH 018/113] Support aeson 2 --- yesod-auth/ChangeLog.md | 4 ++++ yesod-auth/Yesod/Auth.hs | 3 +-- yesod-auth/Yesod/Auth/GoogleEmail2.hs | 24 ++++++++++++++++++++---- yesod-auth/yesod-auth.cabal | 2 +- 4 files changed, 26 insertions(+), 7 deletions(-) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index 782e12c1..0a5c2267 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-auth +## 1.6.10.5 + +* Add support for aeson 2 + ## 1.6.10.4 * Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index dd69812f..933e76f8 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -52,7 +52,6 @@ import Control.Monad.Trans.Maybe import UnliftIO (withRunInIO, MonadUnliftIO) import Yesod.Auth.Routes -import Data.Aeson hiding (json) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Text (Text) @@ -452,7 +451,7 @@ $nothing

Not logged in. |] jsonCreds creds = - Object $ Map.fromList + toJSON $ Map.fromList [ (T.pack "logged_in", Bool $ maybe False (const True) creds) ] diff --git a/yesod-auth/Yesod/Auth/GoogleEmail2.hs b/yesod-auth/Yesod/Auth/GoogleEmail2.hs index cf79a57f..fbe17d2c 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail2.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail2.hs @@ -87,7 +87,6 @@ import Data.Aeson.Types (FromJSON (parseJSON), parseEither, parseMaybe, withObject, withText) import Data.Conduit import Data.Conduit.Attoparsec (sinkParser) -import qualified Data.HashMap.Strict as M import Data.Maybe (fromMaybe) import Data.Monoid (mappend) import Data.Text (Text) @@ -103,6 +102,13 @@ import Network.HTTP.Conduit (http) import Network.HTTP.Types (renderQueryText) import System.IO.Unsafe (unsafePerformIO) +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.Key +import qualified Data.Aeson.KeyMap +#else +import qualified Data.HashMap.Strict as M +#endif + -- | Plugin identifier. This is used to identify the plugin used for -- authentication. The 'credsPlugin' will contain this value when this @@ -587,9 +593,19 @@ instance FromJSON EmailType where _ -> EmailType t allPersonInfo :: A.Value -> [(Text, Text)] -allPersonInfo (A.Object o) = map enc $ M.toList o - where enc (key, A.String s) = (key, s) - enc (key, v) = (key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v) +allPersonInfo (A.Object o) = map enc $ mapToList o + where + enc (key, A.String s) = (keyToText key, s) + enc (key, v) = (keyToText key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v) + +#if MIN_VERSION_aeson(2, 0, 0) + keyToText = Data.Aeson.Key.toText + mapToList = Data.Aeson.KeyMap.toList +#else + keyToText = id + mapToList = M.toList +#endif + allPersonInfo _ = [] diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index f5aa0bce..45a67235 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: yesod-auth -version: 1.6.10.4 +version: 1.6.10.5 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin From 3583fe2a030e688ff64a461c967e9fc433425e30 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Feb 2022 05:55:17 +0200 Subject: [PATCH 019/113] Update yesod-bin for aeson 2 --- yesod-bin/ChangeLog.md | 4 ++++ yesod-bin/Keter.hs | 6 ++++++ yesod-bin/yesod-bin.cabal | 3 ++- 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index a7780c0a..9f05e13d 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-bin +## 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) diff --git a/yesod-bin/Keter.hs b/yesod-bin/Keter.hs index 07810ea8..94024e18 100644 --- a/yesod-bin/Keter.hs +++ b/yesod-bin/Keter.hs @@ -1,10 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Keter ( keter ) where import Data.Yaml + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.KeyMap as Map +#else import qualified Data.HashMap.Strict as Map +#endif import qualified Data.Text as T import System.Environment (getEnvironment) import System.Exit diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 20da5ef8..1296d7ff 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.6.1 +version: 1.6.2 license: MIT license-file: LICENSE author: Michael Snoyman @@ -61,6 +61,7 @@ executable yesod , warp-tls >= 3.0.1 , yaml >= 0.8 && < 0.12 , zlib >= 0.5 + , aeson ghc-options: -Wall -threaded -rtsopts main-is: main.hs From 6e7e7299ba6de8a0d158cad159a2bc2b508110e9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Feb 2022 06:00:02 +0200 Subject: [PATCH 020/113] Update yesod for aeson 2 --- yesod/ChangeLog.md | 4 ++++ yesod/Yesod/Default/Config.hs | 12 +++++++++--- yesod/Yesod/Default/Config2.hs | 7 ++++++- yesod/yesod.cabal | 2 +- 4 files changed, 20 insertions(+), 5 deletions(-) diff --git a/yesod/ChangeLog.md b/yesod/ChangeLog.md index 4929bf12..8915035f 100644 --- a/yesod/ChangeLog.md +++ b/yesod/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod +## 1.6.2 + +* aeson 2 + ## 1.6.1.2 * Fix compatibility with template-haskell 2.17 [#1730](https://github.com/yesodweb/yesod/pull/1730) diff --git a/yesod/Yesod/Default/Config.hs b/yesod/Yesod/Default/Config.hs index 8cdbd3bc..65318c5a 100644 --- a/yesod/Yesod/Default/Config.hs +++ b/yesod/Yesod/Default/Config.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} module Yesod.Default.Config @@ -19,12 +20,17 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Yaml import Data.Maybe (fromMaybe) -import qualified Data.HashMap.Strict as M import System.Environment (getArgs, getProgName, getEnvironment) import System.Exit (exitFailure) import Data.Streaming.Network (HostPreference) import Data.String (fromString) +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.KeyMap as M +#else +import qualified Data.HashMap.Strict as M +#endif + -- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and -- Production environments data DefaultEnv = Development @@ -143,7 +149,7 @@ configSettings env0 = ConfigSettings Object obj -> return obj _ -> fail "Expected Object" let senv = show env - tenv = T.pack senv + tenv = fromString senv maybe (error $ "Could not find environment: " ++ senv) return @@ -237,5 +243,5 @@ withYamlEnvironment fp env f = do Left err -> fail $ "Invalid YAML file: " ++ show fp ++ " " ++ prettyPrintParseException err Right (Object obj) - | Just v <- M.lookup (T.pack $ show env) obj -> parseMonad f v + | Just v <- M.lookup (fromString $ show env) obj -> parseMonad f v _ -> fail $ "Could not find environment: " ++ show env diff --git a/yesod/Yesod/Default/Config2.hs b/yesod/Yesod/Default/Config2.hs index 08abe31b..5a2a8ed6 100644 --- a/yesod/Yesod/Default/Config2.hs +++ b/yesod/Yesod/Default/Config2.hs @@ -30,7 +30,6 @@ import Data.Yaml.Config import Data.Semigroup import Data.Aeson -import qualified Data.HashMap.Strict as H import System.Environment (getEnvironment) import Network.Wai (Application) import Network.Wai.Handler.Warp @@ -43,6 +42,12 @@ import Network.Wai.Logger (clockDateCacher) import Yesod.Core.Types (Logger (Logger)) import System.Log.FastLogger (LoggerSet) +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.KeyMap as H +#else +import qualified Data.HashMap.Strict as H +#endif + #ifndef mingw32_HOST_OS import System.Posix.Signals (installHandler, sigINT, Handler(Catch)) #endif diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 4da584e1..46c6b239 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 1.6.1.2 +version: 1.6.2 license: MIT license-file: LICENSE author: Michael Snoyman From 7af2cd04b6dc8ef5149dedc70fb02db5f4091d0b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Feb 2022 06:01:35 +0200 Subject: [PATCH 021/113] Allow newer GHC --- yesod-auth-oauth/ChangeLog.md | 4 ++++ yesod-auth-oauth/Yesod/Auth/OAuth.hs | 10 ++-------- yesod-auth-oauth/yesod-auth-oauth.cabal | 2 +- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/yesod-auth-oauth/ChangeLog.md b/yesod-auth-oauth/ChangeLog.md index 9d5d5dbb..280564e2 100644 --- a/yesod-auth-oauth/ChangeLog.md +++ b/yesod-auth-oauth/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-auth-oauth +## 1.6.1 + +* Allow newer GHC + ## 1.6.0.3 * Allow yesod-form 1.7 diff --git a/yesod-auth-oauth/Yesod/Auth/OAuth.hs b/yesod-auth-oauth/Yesod/Auth/OAuth.hs index f2ccae1b..96ea8029 100644 --- a/yesod-auth-oauth/Yesod/Auth/OAuth.hs +++ b/yesod-auth-oauth/Yesod/Auth/OAuth.hs @@ -18,7 +18,6 @@ import Control.Applicative as A ((<$>), (<*>)) import Control.Arrow ((***)) import UnliftIO.Exception import Control.Monad.IO.Class -import UnliftIO (MonadUnliftIO) import Data.ByteString (ByteString) import Data.Maybe import Data.Text (Text) @@ -53,14 +52,9 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login oauthSessionName = "__oauth_token_secret" dispatch - :: ( MonadHandler m - , master ~ HandlerSite m - , Auth ~ SubHandlerSite m - , MonadUnliftIO m - ) - => Text + :: Text -> [Text] - -> m TypedContent + -> AuthHandler master TypedContent dispatch "GET" ["forward"] = do render <- getUrlRender tm <- getRouteToParent diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index a8969623..3e91ff69 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: yesod-auth-oauth -version: 1.6.0.3 +version: 1.6.1 license: BSD3 license-file: LICENSE author: Hiromi Ishii From b4b32cb341f7d2a19be4949f889c2977377cf4e1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Feb 2022 06:27:32 +0200 Subject: [PATCH 022/113] Change yesod-auth version --- yesod-auth/ChangeLog.md | 6 +++++- yesod-auth/yesod-auth.cabal | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index 0a5c2267..c354c31f 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,8 +1,12 @@ # ChangeLog for yesod-auth +## 1.6.11 + +* Add support for aeson 2 + ## 1.6.10.5 -* Add support for aeson 2 +* Fix German translations of AuthMessage [#1741](https://github.com/yesodweb/yesod/pull/1741) ## 1.6.10.4 diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 45a67235..8ee16554 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: yesod-auth -version: 1.6.10.5 +version: 1.6.11 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin From 48d05fd6ab12ad440e1f2aa32684ed08b23f0613 Mon Sep 17 00:00:00 2001 From: Sergiu Starciuc Date: Wed, 2 Mar 2022 19:49:09 +0300 Subject: [PATCH 023/113] Color field (#1748) This PR adds a new colorField function to create an html color field () as described at https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input/color --- yesod-form/ChangeLog.md | 4 ++++ yesod-form/Yesod/Form/Fields.hs | 23 +++++++++++++++++++++++ yesod-form/Yesod/Form/I18n/Chinese.hs | 1 + yesod-form/Yesod/Form/I18n/Croatian.hs | 1 + yesod-form/Yesod/Form/I18n/Czech.hs | 1 + yesod-form/Yesod/Form/I18n/Dutch.hs | 1 + yesod-form/Yesod/Form/I18n/English.hs | 1 + yesod-form/Yesod/Form/I18n/French.hs | 1 + yesod-form/Yesod/Form/I18n/German.hs | 1 + yesod-form/Yesod/Form/I18n/Japanese.hs | 1 + yesod-form/Yesod/Form/I18n/Korean.hs | 1 + yesod-form/Yesod/Form/I18n/Norwegian.hs | 1 + yesod-form/Yesod/Form/I18n/Portuguese.hs | 1 + yesod-form/Yesod/Form/I18n/Russian.hs | 1 + yesod-form/Yesod/Form/I18n/Spanish.hs | 1 + yesod-form/Yesod/Form/I18n/Swedish.hs | 1 + yesod-form/Yesod/Form/Types.hs | 1 + yesod-form/yesod-form.cabal | 2 +- 18 files changed, 43 insertions(+), 1 deletion(-) diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index 5d37f2f8..9441bc04 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-form +## 1.7.1 + +* Added `colorField` for creating a html color field (``) [#1748](https://github.com/yesodweb/yesod/pull/1748) + ## 1.7.0 * Extended `OptionList` by `OptionListGrouped` and implemented grouped select fields (` +|] + , fieldEnctype = UrlEncoded + } + where + isHexColor :: String -> Bool + isHexColor ['#',a,b,c,d,e,f] = all isHexDigit [a,b,c,d,e,f] + isHexColor _ = False diff --git a/yesod-form/Yesod/Form/I18n/Chinese.hs b/yesod-form/Yesod/Form/I18n/Chinese.hs index 5d85effc..2a7c7102 100644 --- a/yesod-form/Yesod/Form/I18n/Chinese.hs +++ b/yesod-form/Yesod/Form/I18n/Chinese.hs @@ -24,3 +24,4 @@ chineseFormMessage (MsgInvalidBool t) = "无效的逻辑值: " `mappend` t chineseFormMessage MsgBoolYes = "是" chineseFormMessage MsgBoolNo = "否" chineseFormMessage MsgDelete = "删除?" +chineseFormMessage (MsgInvalidHexColorFormat t) = "颜色无效，必须为 #rrggbb 十六进制格式: " `mappend` t diff --git a/yesod-form/Yesod/Form/I18n/Croatian.hs b/yesod-form/Yesod/Form/I18n/Croatian.hs index 1f6eca6f..6dec3140 100644 --- a/yesod-form/Yesod/Form/I18n/Croatian.hs +++ b/yesod-form/Yesod/Form/I18n/Croatian.hs @@ -24,3 +24,4 @@ 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 diff --git a/yesod-form/Yesod/Form/I18n/Czech.hs b/yesod-form/Yesod/Form/I18n/Czech.hs index a75a2ffb..c676856d 100644 --- a/yesod-form/Yesod/Form/I18n/Czech.hs +++ b/yesod-form/Yesod/Form/I18n/Czech.hs @@ -24,3 +24,4 @@ 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 diff --git a/yesod-form/Yesod/Form/I18n/Dutch.hs b/yesod-form/Yesod/Form/I18n/Dutch.hs index a872d1c7..d8a2c1cd 100644 --- a/yesod-form/Yesod/Form/I18n/Dutch.hs +++ b/yesod-form/Yesod/Form/I18n/Dutch.hs @@ -24,3 +24,4 @@ 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 diff --git a/yesod-form/Yesod/Form/I18n/English.hs b/yesod-form/Yesod/Form/I18n/English.hs index 7feec5b1..c2f85fd6 100644 --- a/yesod-form/Yesod/Form/I18n/English.hs +++ b/yesod-form/Yesod/Form/I18n/English.hs @@ -24,3 +24,4 @@ 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 diff --git a/yesod-form/Yesod/Form/I18n/French.hs b/yesod-form/Yesod/Form/I18n/French.hs index 81a36a7e..f2a71767 100644 --- a/yesod-form/Yesod/Form/I18n/French.hs +++ b/yesod-form/Yesod/Form/I18n/French.hs @@ -24,3 +24,4 @@ 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 diff --git a/yesod-form/Yesod/Form/I18n/German.hs b/yesod-form/Yesod/Form/I18n/German.hs index ec800547..88158f1a 100644 --- a/yesod-form/Yesod/Form/I18n/German.hs +++ b/yesod-form/Yesod/Form/I18n/German.hs @@ -24,3 +24,4 @@ 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 diff --git a/yesod-form/Yesod/Form/I18n/Japanese.hs b/yesod-form/Yesod/Form/I18n/Japanese.hs index 9e929c7a..8e2ca0de 100644 --- a/yesod-form/Yesod/Form/I18n/Japanese.hs +++ b/yesod-form/Yesod/Form/I18n/Japanese.hs @@ -24,3 +24,4 @@ japaneseFormMessage (MsgInvalidBool t) = "無効なbool値です: " `mappend` t japaneseFormMessage MsgBoolYes = "はい" japaneseFormMessage MsgBoolNo = "いいえ" japaneseFormMessage MsgDelete = "削除しますか?" +japaneseFormMessage (MsgInvalidHexColorFormat t) = "無効な色。＃rrggbb16進形式である必要があります: " `mappend` t diff --git a/yesod-form/Yesod/Form/I18n/Korean.hs b/yesod-form/Yesod/Form/I18n/Korean.hs index 212f298d..5f311994 100644 --- a/yesod-form/Yesod/Form/I18n/Korean.hs +++ b/yesod-form/Yesod/Form/I18n/Korean.hs @@ -24,3 +24,4 @@ koreanFormMessage (MsgInvalidBool t) = "잘못된 불(boolean)입니다: " `mapp koreanFormMessage MsgBoolYes = "예" koreanFormMessage MsgBoolNo = "아니오" koreanFormMessage MsgDelete = "삭제하시겠습니까?" +koreanFormMessage (MsgInvalidHexColorFormat t) = "색상이 잘못되었습니다. #rrggbb 16진수 형식이어야 합니다.: " `mappend` t diff --git a/yesod-form/Yesod/Form/I18n/Norwegian.hs b/yesod-form/Yesod/Form/I18n/Norwegian.hs index cb74eaad..f6883dd0 100644 --- a/yesod-form/Yesod/Form/I18n/Norwegian.hs +++ b/yesod-form/Yesod/Form/I18n/Norwegian.hs @@ -24,3 +24,4 @@ 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 diff --git a/yesod-form/Yesod/Form/I18n/Portuguese.hs b/yesod-form/Yesod/Form/I18n/Portuguese.hs index 01aabede..b4b892a7 100644 --- a/yesod-form/Yesod/Form/I18n/Portuguese.hs +++ b/yesod-form/Yesod/Form/I18n/Portuguese.hs @@ -24,3 +24,4 @@ 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 diff --git a/yesod-form/Yesod/Form/I18n/Russian.hs b/yesod-form/Yesod/Form/I18n/Russian.hs index c235270a..efaa1b75 100644 --- a/yesod-form/Yesod/Form/I18n/Russian.hs +++ b/yesod-form/Yesod/Form/I18n/Russian.hs @@ -24,3 +24,4 @@ russianFormMessage (MsgInvalidBool t) = "Неверное логическое russianFormMessage MsgBoolYes = "Да" russianFormMessage MsgBoolNo = "Нет" russianFormMessage MsgDelete = "Удалить?" +russianFormMessage (MsgInvalidHexColorFormat t) = "Недопустимое значение цвета, должен быть в шестнадцатеричном формате #rrggbb: " `mappend` t diff --git a/yesod-form/Yesod/Form/I18n/Spanish.hs b/yesod-form/Yesod/Form/I18n/Spanish.hs index 795e67a4..7d38251d 100644 --- a/yesod-form/Yesod/Form/I18n/Spanish.hs +++ b/yesod-form/Yesod/Form/I18n/Spanish.hs @@ -25,3 +25,4 @@ 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 diff --git a/yesod-form/Yesod/Form/I18n/Swedish.hs b/yesod-form/Yesod/Form/I18n/Swedish.hs index ed3e3b9b..39622ba4 100644 --- a/yesod-form/Yesod/Form/I18n/Swedish.hs +++ b/yesod-form/Yesod/Form/I18n/Swedish.hs @@ -24,3 +24,4 @@ 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 diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs index bfc3e179..df13ab32 100644 --- a/yesod-form/Yesod/Form/Types.hs +++ b/yesod-form/Yesod/Form/Types.hs @@ -229,4 +229,5 @@ data FormMessage = MsgInvalidInteger Text | MsgBoolYes | MsgBoolNo | MsgDelete + | MsgInvalidHexColorFormat Text deriving (Show, Eq, Read) diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 5ef05965..dc53d239 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: yesod-form -version: 1.7.0 +version: 1.7.1 license: MIT license-file: LICENSE author: Michael Snoyman From d3808c3a978cf0237626aacb27a777e9333988e4 Mon Sep 17 00:00:00 2001 From: Boris Lykah Date: Mon, 21 Mar 2022 12:17:24 -0600 Subject: [PATCH 024/113] Create instances for ToContent Void, ToTypedContent Void --- yesod-core/src/Yesod/Core/Content.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/yesod-core/src/Yesod/Core/Content.hs b/yesod-core/src/Yesod/Core/Content.hs index d9741d92..bcb1ff1b 100644 --- a/yesod-core/src/Yesod/Core/Content.hs +++ b/yesod-core/src/Yesod/Core/Content.hs @@ -64,6 +64,7 @@ import qualified Data.Conduit.Internal as CI import qualified Data.Aeson as J import Data.Text.Lazy.Builder (toLazyText) +import Data.Void (Void, absurd) import Yesod.Core.Types import Text.Lucius (Css, renderCss) import Text.Julius (Javascript, unJavascript) @@ -103,6 +104,8 @@ instance ToContent Html where toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing instance ToContent () where toContent () = toContent B.empty +instance ToContent Void where + toContent = absurd instance ToContent (ContentType, Content) where toContent = snd instance ToContent TypedContent where @@ -276,6 +279,8 @@ instance ToTypedContent TypedContent where toTypedContent = id instance ToTypedContent () where toTypedContent () = TypedContent typePlain (toContent ()) +instance ToTypedContent Void where + toTypedContent = absurd instance ToTypedContent (ContentType, Content) where toTypedContent (ct, content) = TypedContent ct content instance ToTypedContent RepJson where From 8fb0cbb31a3a9aa75c9d32770a8e582954efb008 Mon Sep 17 00:00:00 2001 From: Boris Lykah Date: Tue, 22 Mar 2022 11:44:16 -0600 Subject: [PATCH 025/113] Bump version for yesod-core --- yesod-core/yesod-core.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index f01e5ff9..9bf163f1 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.21.0 +version: 1.6.22.0 license: MIT license-file: LICENSE author: Michael Snoyman From 7d44c38c91b8e9ca063a0aa2fb761cfa2baefd47 Mon Sep 17 00:00:00 2001 From: Boris Lykah Date: Tue, 22 Mar 2022 11:46:09 -0600 Subject: [PATCH 026/113] Update changelog --- yesod-core/ChangeLog.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 47d63ffb..6436dcb5 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -2,7 +2,10 @@ ## Unreleased +## 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) ## 1.6.21.0 From 08d37a1857381a19c8906f2c39ba3611a3b13574 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 14:02:25 -0400 Subject: [PATCH 027/113] Add test showing the failures --- .../test/YesodCoreTest/ErrorHandling.hs | 40 +++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 048342ce..218d5634 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -6,6 +6,10 @@ module YesodCoreTest.ErrorHandling , Widget , resourcesApp ) where + +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 @@ -45,6 +49,9 @@ mkYesod "App" [parseRoutes| /auth-not-adequate AuthNotAdequateR GET /args-not-valid ArgsNotValidR POST /only-plain-text OnlyPlainTextR GET + +/allocation-limit AlocationLimitR GET +/thread-killed ThreadKilledR GET |] overrideStatus :: Status @@ -111,6 +118,24 @@ goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n" getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent +getAlocationLimitR :: Handler Html +getAlocationLimitR = do + liftIO $ do + Mem.setAllocationCounter 1 -- very low limit + Mem.enableAllocationLimit + defaultLayout $ [whamlet| +

this will trigger https://hackage.haskell.org/package/base-4.16.0.0/docs/Control-Exception.html#t:AllocationLimitExceeded + which we need to catch + |] + +-- 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" + + getErrorR :: Int -> Handler () getErrorR 1 = setSession undefined "foo" getErrorR 2 = setSession "foo" undefined @@ -154,10 +179,13 @@ 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 "thread killed = 500" caseThreadKilled500 + it "allocation limit = 500" caseAllocationLimit500 runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f + caseNotFound :: IO () caseNotFound = runner $ do res <- request defaultRequest @@ -291,3 +319,15 @@ caseVideoBadMethod = runner $ do ("accept", "video/webm") : requestHeaders defaultRequest } assertStatus 405 res + +caseAllocationLimit500 :: IO () +caseAllocationLimit500 = runner $ do + res <- request defaultRequest { pathInfo = ["allocation-limit"] } + assertStatus 500 res + assertBodyContains "Internal Server Error" res + +caseThreadKilled500 :: IO () +caseThreadKilled500 = runner $ do + res <- request defaultRequest { pathInfo = ["thread-killed"] } + assertStatus 500 res + assertBodyContains "Internal Server Error" res From 42abd9b666d77256ce534328aa752aeeda6dcc2a Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 14:20:46 -0400 Subject: [PATCH 028/113] add explicit exports --- yesod-core/src/Yesod/Core/Internal/Run.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 8f0afee9..89530400 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -5,8 +5,21 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} -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 Yesod.Core.Internal.Response import Data.ByteString.Builder (toLazyByteString) From eb7405765d6d5ebd22e25c6cd8e46c1a64d3f13c Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 14:47:27 -0400 Subject: [PATCH 029/113] Add async exception handling for basic runner. --- yesod-core/src/Yesod/Core/Internal/Run.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 89530400..6ad7cd3f 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -21,6 +21,8 @@ module Yesod.Core.Internal.Run ) where +import qualified GHC.Conc.Sync as Sync +import qualified Control.Exception as EUnsafe import Yesod.Core.Internal.Response import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BL @@ -52,6 +54,24 @@ import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Yesod.Routes.Class (Route, renderRoute) import Control.DeepSeq (($!!), NFData) import UnliftIO.Exception +import UnliftIO(MonadUnliftIO, withRunInIO) + +-- | like `catch` but doesn't check for async exceptions, +-- thereby catching them too. +-- This is desirable for letting yesod generate a 500 error page +-- rather then warp. +-- +-- Normally this is VERY dubious. you need to rethrow. +-- recovrery from async isn't allowed. +-- see async section: https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/ +unsafeAsyncCatch + :: (MonadUnliftIO m, Exception e) + => m a -- ^ action + -> (e -> m a) -- ^ handler + -> m a +unsafeAsyncCatch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do + liftIO Sync.disableAllocationLimit -- otherwise it can throw again on rendering the 500 page + run (g e) -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse @@ -84,7 +104,7 @@ basicRunHandler rhe handler yreq resState = do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ - contents' <- catchAny + contents' <- unsafeAsyncCatch (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) From 4c1719cb6e4b99233eb29b2dffdc2028c8d00d37 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 15:15:49 -0400 Subject: [PATCH 030/113] Disable the allocation limit within the test instead I don't think we should add that to the function seems odly specific --- yesod-core/src/Yesod/Core/Internal/Run.hs | 9 ++++----- yesod-core/test/YesodCoreTest/ErrorHandling.hs | 6 ++++-- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 6ad7cd3f..a7530eb5 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -70,7 +70,6 @@ unsafeAsyncCatch -> (e -> m a) -- ^ handler -> m a unsafeAsyncCatch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do - liftIO Sync.disableAllocationLimit -- otherwise it can throw again on rendering the 500 page run (g e) -- | Convert a synchronous exception into an ErrorResponse @@ -97,7 +96,7 @@ basicRunHandler :: ToTypedContent c -> YesodRequest -> InternalState -> IO (GHState, HandlerContents) -basicRunHandler rhe handler yreq resState = do +basicRunHandler rhe handler yreq resState = mask $ \unmask -> do -- Create a mutable ref to hold the state. We use mutable refs so -- that the updates will survive runtime exceptions. istate <- I.newIORef defState @@ -105,7 +104,7 @@ basicRunHandler rhe handler yreq resState = do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ contents' <- unsafeAsyncCatch - (do + (unmask $ do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) -- Success! Wrap it up in an @HCContent@ @@ -219,9 +218,9 @@ runHandler :: ToTypedContent c => RunHandlerEnv site site -> HandlerFor site c -> YesodApp -runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do +runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> mask $ \unmask -> do -- Get the raw state and original contents - (state, contents0) <- basicRunHandler rhe handler yreq resState + (state, contents0) <- unmask $ basicRunHandler rhe handler yreq resState -- Evaluate the unfortunately-lazy session and headers, -- propagating exceptions into the contents diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 218d5634..4605fd40 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -17,6 +17,7 @@ import Network.Wai.Test import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 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) @@ -119,14 +120,15 @@ getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent getAlocationLimitR :: Handler Html -getAlocationLimitR = do +getAlocationLimitR = + (do liftIO $ do Mem.setAllocationCounter 1 -- very low limit Mem.enableAllocationLimit defaultLayout $ [whamlet|

this will trigger https://hackage.haskell.org/package/base-4.16.0.0/docs/Control-Exception.html#t:AllocationLimitExceeded which we need to catch - |] + |]) `finally` (liftIO $ Mem.disableAllocationLimit) -- this handler kills it's own thread getThreadKilledR :: Handler Html From e284a68a9fa14f3da9a1da04dee8b2bd8526e320 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 15:18:38 -0400 Subject: [PATCH 031/113] Remove the use of masks I don't think these are neccisary. If an exception get's delivered at these points, we couldn't do anything about it anyway --- yesod-core/src/Yesod/Core/Internal/Run.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index a7530eb5..618665f2 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -96,7 +96,7 @@ basicRunHandler :: ToTypedContent c -> YesodRequest -> InternalState -> IO (GHState, HandlerContents) -basicRunHandler rhe handler yreq resState = mask $ \unmask -> do +basicRunHandler rhe handler yreq resState = do -- Create a mutable ref to hold the state. We use mutable refs so -- that the updates will survive runtime exceptions. istate <- I.newIORef defState @@ -104,7 +104,7 @@ basicRunHandler rhe handler yreq resState = mask $ \unmask -> do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ contents' <- unsafeAsyncCatch - (unmask $ do + (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) -- Success! Wrap it up in an @HCContent@ @@ -218,9 +218,9 @@ runHandler :: ToTypedContent c => RunHandlerEnv site site -> HandlerFor site c -> YesodApp -runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> mask $ \unmask -> do +runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do -- Get the raw state and original contents - (state, contents0) <- unmask $ basicRunHandler rhe handler yreq resState + (state, contents0) <- basicRunHandler rhe handler yreq resState -- Evaluate the unfortunately-lazy session and headers, -- propagating exceptions into the contents From 5b96d949155eb1b09bed1d033e1f220989fcf31d Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 15:45:20 -0400 Subject: [PATCH 032/113] Fix it for async exceptions in the sessions as well --- yesod-core/src/Yesod/Core/Internal/Run.hs | 11 ++++++++-- .../test/YesodCoreTest/ErrorHandling.hs | 20 +++++++++++++++++-- 2 files changed, 27 insertions(+), 4 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 618665f2..c1ffe100 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -21,7 +21,6 @@ module Yesod.Core.Internal.Run ) where -import qualified GHC.Conc.Sync as Sync import qualified Control.Exception as EUnsafe import Yesod.Core.Internal.Response import Data.ByteString.Builder (toLazyByteString) @@ -72,6 +71,12 @@ unsafeAsyncCatch unsafeAsyncCatch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do run (g e) +unsafeAsyncCatchAny :: (MonadUnliftIO m) + => m a -- ^ action + -> (SomeException -> m a) -- ^ handler + -> m a +unsafeAsyncCatchAny = unsafeAsyncCatch + -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse toErrorHandler e0 = handleAny errFromShow $ @@ -204,11 +209,13 @@ handleContents handleError' finalSession headers contents = -- | Evaluate the given value. If an exception is thrown, use it to -- replace the provided contents and then return @mempty@ in place of the -- evaluated value. +-- +-- Note that this also catches async exceptions. evalFallback :: (Monoid w, NFData w) => HandlerContents -> w -> IO (w, HandlerContents) -evalFallback contents val = catchAny +evalFallback contents val = unsafeAsyncCatchAny (fmap (, contents) (evaluate $!! val)) (fmap ((mempty, ) . HCError) . toErrorHandler) diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 4605fd40..b35c93d2 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ViewPatterns #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest @@ -53,6 +54,7 @@ mkYesod "App" [parseRoutes| /allocation-limit AlocationLimitR GET /thread-killed ThreadKilledR GET +/async-session AsyncSessionR GET |] overrideStatus :: Status @@ -128,7 +130,7 @@ getAlocationLimitR = defaultLayout $ [whamlet|

this will trigger https://hackage.haskell.org/package/base-4.16.0.0/docs/Control-Exception.html#t:AllocationLimitExceeded which we need to catch - |]) `finally` (liftIO $ Mem.disableAllocationLimit) + |]) `finally` liftIO Mem.disableAllocationLimit -- this handler kills it's own thread getThreadKilledR :: Handler Html @@ -137,6 +139,14 @@ getThreadKilledR = do liftIO $ Async.withAsync (Conc.killThread x) Async.wait pure "unreachablle" +getAsyncSessionR :: Handler Html +getAsyncSessionR = do + setSession "jap" $ foldMap (pack . show) [0..999999999999999999999999] -- it's going to take a while to figure this one out + x <- liftIO Conc.myThreadId + liftIO $ forkIO $ do + liftIO $ Conc.threadDelay 100_000 + Conc.killThread x + pure "reachable" getErrorR :: Int -> Handler () getErrorR 1 = setSession undefined "foo" @@ -183,11 +193,11 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do it "accept video, bad method -> 405" caseVideoBadMethod it "thread killed = 500" caseThreadKilled500 it "allocation limit = 500" caseAllocationLimit500 + it "async session exception = 500" asyncSessionKilled500 runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f - caseNotFound :: IO () caseNotFound = runner $ do res <- request defaultRequest @@ -333,3 +343,9 @@ caseThreadKilled500 = runner $ do res <- request defaultRequest { pathInfo = ["thread-killed"] } assertStatus 500 res assertBodyContains "Internal Server Error" res + +asyncSessionKilled500 :: IO () +asyncSessionKilled500 = runner $ do + res <- request defaultRequest { pathInfo = ["async-session"] } + assertStatus 500 res + assertBodyContains "Internal Server Error" res From f48485e18154c04276bac822f74d14538e4dd3f0 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 15:46:47 -0400 Subject: [PATCH 033/113] Bump version number --- yesod-core/yesod-core.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index f01e5ff9..9bf163f1 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.21.0 +version: 1.6.22.0 license: MIT license-file: LICENSE author: Michael Snoyman From 764fd94bc62796642fccdf325338e8f35503a728 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 15:51:10 -0400 Subject: [PATCH 034/113] add changelog entry --- yesod-core/ChangeLog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 47d63ffb..85f87ef0 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -3,6 +3,7 @@ ## Unreleased * Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745) +* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753) ## 1.6.21.0 From 9039df924db22a54c188167ae80855c3e64d634a Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 22 Mar 2022 20:29:50 +0000 Subject: [PATCH 035/113] Allow building with template-haskell-2.18.0 --- yesod-core/src/Yesod/Routes/TH/Dispatch.hs | 16 ++++++++++++---- yesod-core/src/Yesod/Routes/TH/RenderRoute.hs | 11 +++++++++-- yesod-core/src/Yesod/Routes/TH/RouteAttrs.hs | 7 ++++++- 3 files changed, 27 insertions(+), 7 deletions(-) diff --git a/yesod-core/src/Yesod/Routes/TH/Dispatch.hs b/yesod-core/src/Yesod/Routes/TH/Dispatch.hs index c061a1c2..1d12c9d9 100644 --- a/yesod-core/src/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-core/src/Yesod/Routes/TH/Dispatch.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} module Yesod.Routes.TH.Dispatch ( MkDispatchSettings (..) @@ -73,7 +74,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do handlePiece (Static str) = return (LitP $ StringL str, Nothing) handlePiece (Dynamic _) = do x <- newName "dyn" - let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) + let pat = ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x]) return (pat, Just $ VarE x) handlePieces :: [Piece a] -> Q ([Pat], [Exp]) @@ -86,7 +87,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do mkPathPat final = foldr addPat final where - addPat x y = ConP '(:) [x, y] + addPat x y = conPCompat '(:) [x, y] go :: SDC -> ResourceTree a -> Q Clause go sdc (ResourceParent name _check pieces children) = do @@ -124,11 +125,11 @@ mkDispatchClause MkDispatchSettings {..} resources = do Methods multi methods -> do (finalPat, mfinalE) <- case multi of - Nothing -> return (ConP '[] [], Nothing) + Nothing -> return (conPCompat '[] [], Nothing) Just _ -> do multiName <- newName "multi" let pat = ViewP (VarE 'fromPathMultiPiece) - (ConP 'Just [VarP multiName]) + (conPCompat 'Just [VarP multiName]) return (pat, Just $ VarE multiName) let dynsMulti = @@ -200,3 +201,10 @@ mkDispatchClause MkDispatchSettings {..} resources = do defaultGetHandler :: Maybe String -> String -> Q Exp defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s + +conPCompat :: Name -> [Pat] -> Pat +conPCompat n pats = ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + pats diff --git a/yesod-core/src/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/src/Yesod/Routes/TH/RenderRoute.hs index 09654c83..6d9e4de1 100644 --- a/yesod-core/src/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-core/src/Yesod/Routes/TH/RenderRoute.hs @@ -67,7 +67,7 @@ mkRenderRouteClauses = let cnt = length $ filter isDynamic pieces dyns <- replicateM cnt $ newName "dyn" child <- newName "child" - let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] + let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child] pack' <- [|pack|] tsp <- [|toPathPiece|] @@ -100,7 +100,7 @@ mkRenderRouteClauses = case resourceDispatch res of Subsite{} -> return <$> newName "sub" _ -> return [] - let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub + let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub pack' <- [|pack|] tsp <- [|toPathPiece|] @@ -182,3 +182,10 @@ 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 diff --git a/yesod-core/src/Yesod/Routes/TH/RouteAttrs.hs b/yesod-core/src/Yesod/Routes/TH/RouteAttrs.hs index 0f1aeece..72b24b49 100644 --- a/yesod-core/src/Yesod/Routes/TH/RouteAttrs.hs +++ b/yesod-core/src/Yesod/Routes/TH/RouteAttrs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} module Yesod.Routes.TH.RouteAttrs @@ -26,7 +27,11 @@ goTree front (ResourceParent name _check pieces trees) = toIgnore = length $ filter isDynamic pieces isDynamic Dynamic{} = True isDynamic Static{} = False - front' = front . ConP (mkName name) . ignored + front' = front . ConP (mkName name) +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + . ignored goRes :: (Pat -> Pat) -> Resource a -> Q Clause goRes front Resource {..} = From 24d3ea9e53a9e8b29d168bf5574f8c341c100312 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Tue, 22 Mar 2022 23:02:44 +0000 Subject: [PATCH 036/113] Fix building yesod-bin with Cabal-3.6 --- yesod-bin/AddHandler.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/yesod-bin/AddHandler.hs b/yesod-bin/AddHandler.hs index 52d57cdd..d06df811 100644 --- a/yesod-bin/AddHandler.hs +++ b/yesod-bin/AddHandler.hs @@ -16,6 +16,9 @@ import Distribution.PackageDescription.Parse (readGenericPackageDescription) #else import Distribution.PackageDescription.Parse (readPackageDescription) #endif +#if MIN_VERSION_Cabal(3, 6, 0) +import Distribution.Utils.Path +#endif import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription (allBuildInfo, hsSourceDirs) import Distribution.Verbosity (normal) @@ -247,4 +250,8 @@ getSrcDir cabal = do #endif let buildInfo = allBuildInfo pd srcDirs = concatMap hsSourceDirs buildInfo +#if MIN_VERSION_Cabal(3, 6, 0) + return $ maybe "." getSymbolicPath $ listToMaybe srcDirs +#else return $ fromMaybe "." $ listToMaybe srcDirs +#endif From 3c2b50e08c8f5e24dd74bc52bdc6e9aae41adf9e Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Tue, 22 Mar 2022 23:31:12 +0000 Subject: [PATCH 037/113] bump yesod-core --- yesod-core/yesod-core.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index f01e5ff9..e33d36e1 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.21.0 +version: 1.6.21.1 license: MIT license-file: LICENSE author: Michael Snoyman From 87427c12908a0e963a8187f2aa0deff0ed92fef7 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Tue, 22 Mar 2022 23:31:19 +0000 Subject: [PATCH 038/113] bump yesod-bin --- yesod-bin/yesod-bin.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 1296d7ff..bf83bf8b 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.6.2 +version: 1.6.2.1 license: MIT license-file: LICENSE author: Michael Snoyman From b117e5a4cd6db4eaca6eac9d765723f09338c593 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Tue, 22 Mar 2022 23:36:16 +0000 Subject: [PATCH 039/113] update yesod-core changelog --- yesod-core/ChangeLog.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 47d63ffb..88f29b61 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,8 +1,9 @@ # ChangeLog for yesod-core -## Unreleased +## 1.6.21.1 * Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745) +* Support template-haskell 2.18 [#1754](https://github.com/yesodweb/yesod/pull/1754) ## 1.6.21.0 From c6fab6f4105d4618c06b17898383a21846a1d94f Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Tue, 22 Mar 2022 23:36:25 +0000 Subject: [PATCH 040/113] update yesod-bin changelog --- yesod-bin/ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index 9f05e13d..e3366b11 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-bin +## 1.6.2.1 + +* Support Cabal 3.6 [#1754](https://github.com/yesodweb/yesod/pull/1754) + ## 1.6.2 * aeson 2.0 From 3d65a3bf16e3a0fabcda4460174809c70c0b606b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 24 Mar 2022 10:29:28 +0200 Subject: [PATCH 041/113] Remove NumericUnderscores for older GHCs --- yesod-core/test/YesodCoreTest/ErrorHandling.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index b35c93d2..bc02570f 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -1,6 +1,5 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ViewPatterns #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest @@ -144,7 +143,7 @@ getAsyncSessionR = do setSession "jap" $ foldMap (pack . show) [0..999999999999999999999999] -- it's going to take a while to figure this one out x <- liftIO Conc.myThreadId liftIO $ forkIO $ do - liftIO $ Conc.threadDelay 100_000 + liftIO $ Conc.threadDelay 100000 Conc.killThread x pure "reachable" From 73f20b6285dba31722f43c9c1fe08bb1b41c37f7 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Fri, 25 Mar 2022 07:30:33 -0400 Subject: [PATCH 042/113] Remove sometimes failing test This test sometimes fails on nix builds. I'm not sure why, but it should be superflous with "thread killed = 500" test anyway. They test both for async exceptions. Just a different one. --- .../test/YesodCoreTest/ErrorHandling.hs | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index bc02570f..0995cd62 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -51,7 +51,6 @@ mkYesod "App" [parseRoutes| /args-not-valid ArgsNotValidR POST /only-plain-text OnlyPlainTextR GET -/allocation-limit AlocationLimitR GET /thread-killed ThreadKilledR GET /async-session AsyncSessionR GET |] @@ -120,17 +119,6 @@ goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n" getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent -getAlocationLimitR :: Handler Html -getAlocationLimitR = - (do - liftIO $ do - Mem.setAllocationCounter 1 -- very low limit - Mem.enableAllocationLimit - defaultLayout $ [whamlet| -

this will trigger https://hackage.haskell.org/package/base-4.16.0.0/docs/Control-Exception.html#t:AllocationLimitExceeded - which we need to catch - |]) `finally` liftIO Mem.disableAllocationLimit - -- this handler kills it's own thread getThreadKilledR :: Handler Html getThreadKilledR = do @@ -191,7 +179,6 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do it "accept image, non-existent path -> 404" caseImageNotFound it "accept video, bad method -> 405" caseVideoBadMethod it "thread killed = 500" caseThreadKilled500 - it "allocation limit = 500" caseAllocationLimit500 it "async session exception = 500" asyncSessionKilled500 runner :: Session a -> IO a @@ -331,12 +318,6 @@ caseVideoBadMethod = runner $ do } assertStatus 405 res -caseAllocationLimit500 :: IO () -caseAllocationLimit500 = runner $ do - res <- request defaultRequest { pathInfo = ["allocation-limit"] } - assertStatus 500 res - assertBodyContains "Internal Server Error" res - caseThreadKilled500 :: IO () caseThreadKilled500 = runner $ do res <- request defaultRequest { pathInfo = ["thread-killed"] } From 4daf1d21079167bd34dd8ad6acf0e41cc4801a3f Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Fri, 25 Mar 2022 07:51:57 -0400 Subject: [PATCH 043/113] update changelog --- yesod-core/ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index fae259fa..94890204 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-core +## 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) From d54dbf5fd655aa5512c3f470354b09bbe4125ea0 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Fri, 25 Mar 2022 07:52:32 -0400 Subject: [PATCH 044/113] bump version number --- yesod-core/yesod-core.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 9bf163f1..d900011c 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.22.0 +version: 1.6.22.1 license: MIT license-file: LICENSE author: Michael Snoyman From 5f71a49c0fdbc227660a1667b09c517d7ac71f55 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 13 Apr 2022 10:10:35 -0600 Subject: [PATCH 045/113] Support persistent-2.14 --- yesod-persistent/Yesod/Persist/Core.hs | 31 +++++++++++++++++++------- 1 file changed, 23 insertions(+), 8 deletions(-) diff --git a/yesod-persistent/Yesod/Persist/Core.hs b/yesod-persistent/Yesod/Persist/Core.hs index 6a671ca7..79acd444 100644 --- a/yesod-persistent/Yesod/Persist/Core.hs +++ b/yesod-persistent/Yesod/Persist/Core.hs @@ -37,6 +37,9 @@ 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 @@ -187,14 +190,21 @@ getBy404 key = do -- is violated. -- -- @since 1.4.1 -#if MIN_VERSION_persistent(2,5,0) -insert400 :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend) - => val - -> ReaderT backend m (Key val) +#if MIN_VERSION_persistent(2,14,0) +insert400 + :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend, SafeToInsert val) + => val + -> ReaderT backend m (Key val) +#elif MIN_VERSION_persistent(2,5,0) +insert400 + :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend) + => val + -> ReaderT backend m (Key val) #else -insert400 :: (MonadIO m, PersistUnique (PersistEntityBackend val), PersistEntity val) - => val - -> ReaderT (PersistEntityBackend val) m (Key val) +insert400 + :: (MonadIO m, PersistUnique (PersistEntityBackend val), PersistEntity val) + => val + -> ReaderT (PersistEntityBackend val) m (Key val) #endif insert400 datum = do conflict <- checkUnique datum @@ -214,7 +224,12 @@ insert400 datum = do -- | Same as 'insert400', but doesn’t return a key. -- -- @since 1.4.1 -#if MIN_VERSION_persistent(2,5,0) +#if MIN_VERSION_persistent(2,14,0) +insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend, SafeToInsert val) + => val + -> ReaderT backend m () + +#elif MIN_VERSION_persistent(2,5,0) insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend) => val -> ReaderT backend m () From d54c17ef271c1de248a2bcc5e751b0efbbf1a564 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 13 Apr 2022 10:14:17 -0600 Subject: [PATCH 046/113] changelog, version --- yesod-persistent/ChangeLog.md | 4 ++++ yesod-persistent/yesod-persistent.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-persistent/ChangeLog.md b/yesod-persistent/ChangeLog.md index 52286010..e6cf8c2f 100644 --- a/yesod-persistent/ChangeLog.md +++ b/yesod-persistent/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-persistent +## 1.6.0.8 + +* Add support for `persistent-2.14` [#][() + ## 1.6.0.7 * Add support for persistent 2.13. [#1723](https://github.com/yesodweb/yesod/pull/1723) diff --git a/yesod-persistent/yesod-persistent.cabal b/yesod-persistent/yesod-persistent.cabal index b9ca9fff..0b878f7b 100644 --- a/yesod-persistent/yesod-persistent.cabal +++ b/yesod-persistent/yesod-persistent.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: yesod-persistent -version: 1.6.0.7 +version: 1.6.0.8 license: MIT license-file: LICENSE author: Michael Snoyman From 7bec27aa3ca3d15ba4f5bc186b49f2007508b6be Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 13 Apr 2022 10:14:55 -0600 Subject: [PATCH 047/113] changelog link --- yesod-persistent/ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-persistent/ChangeLog.md b/yesod-persistent/ChangeLog.md index e6cf8c2f..be0724d7 100644 --- a/yesod-persistent/ChangeLog.md +++ b/yesod-persistent/ChangeLog.md @@ -2,7 +2,7 @@ ## 1.6.0.8 -* Add support for `persistent-2.14` [#][() +* Add support for `persistent-2.14` [#1706](https://github.com/yesodweb/yesod/pull/1760) ## 1.6.0.7 From 60d074883447e6fc16a4cf4e7ed990f1511a8593 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 13 Apr 2022 16:27:01 -0600 Subject: [PATCH 048/113] Expose SIO type --- yesod-test/ChangeLog.md | 4 ++ yesod-test/Yesod/Test.hs | 42 +++------------------ yesod-test/Yesod/Test/Internal/SIO.hs | 54 +++++++++++++++++++++++++++ yesod-test/yesod-test.cabal | 1 + 4 files changed, 64 insertions(+), 37 deletions(-) create mode 100644 yesod-test/Yesod/Test/Internal/SIO.hs diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index a343b366..03460acc 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-test +## TODO + +* 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) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index eced072c..f2adff40 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -243,10 +243,7 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI 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 @@ -257,7 +254,6 @@ import Text.XML.Cursor hiding (element) import qualified Text.XML.Cursor as C import qualified Text.HTML.DOM as HD import Control.Monad.Trans.Writer -import Data.IORef import qualified Data.Map as M import qualified Web.Cookie as Cookie import qualified Blaze.ByteString.Builder as Builder @@ -281,6 +277,7 @@ import Data.Aeson (FromJSON, eitherDecode') import Control.Monad (unless) import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8) +import Yesod.Test.Internal.SIO {-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-} {-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-} @@ -431,7 +428,7 @@ yit :: String -> YesodExample site () -> YesodSpec site yit label example = tell [YesodSpecItem label example] -- | Modifies the site ('yedSite') of the test, and creates a new WAI app ('yedApp') for it. --- +-- -- yesod-test allows sending requests to your application to test that it handles them correctly. -- In rare cases, you may wish to modify that application in the middle of a test. -- This may be useful if you wish to, for example, test your application under a certain configuration, @@ -455,7 +452,7 @@ testModifySite :: YesodDispatch site => (site -> IO (site, Middleware)) -- ^ A function from the existing site, to a new site and middleware for a WAI app. -> YesodExample site () testModifySite newSiteFn = do - currentSite <- getTestYesod + currentSite <- getTestYesod (newSite, middleware) <- liftIO $ newSiteFn currentSite app <- liftIO $ toWaiAppPlain newSite modifySIO $ \yed -> yed { yedSite = newSite, yedApp = middleware app } @@ -812,7 +809,7 @@ printMatches query = do matches <- htmlQuery query liftIO $ hPutStrLn stderr $ show matches --- | Add a parameter with the given name and value to the request body. +-- | Add a parameter with the given name and value to the request body. -- This function can be called multiple times to add multiple parameters, and be mixed with calls to 'addFile'. -- -- "Post parameter" is an informal description of what is submitted by making an HTTP POST with an HTML @\@. @@ -1367,7 +1364,7 @@ setUrl url' = do -- > get "/foobar" -- > clickOn "a#idofthelink" -- --- @since 1.5.7 +-- @since 1.5.7 clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site () clickOn query = do withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res -> @@ -1596,32 +1593,3 @@ instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) whe return ()) params ($ ()) - --- | State + IO --- --- @since 1.6.0 -newtype SIO s a = SIO (ReaderT (IORef s) IO a) - deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO) - -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 diff --git a/yesod-test/Yesod/Test/Internal/SIO.hs b/yesod-test/Yesod/Test/Internal/SIO.hs new file mode 100644 index 00000000..5f6df528 --- /dev/null +++ b/yesod-test/Yesod/Test/Internal/SIO.hs @@ -0,0 +1,54 @@ +{-# 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 TODO +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 + +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 diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index e49f2541..1c93f246 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -46,6 +46,7 @@ library Yesod.Test.CssQuery Yesod.Test.TransversingCSS Yesod.Test.Internal + Yesod.Test.Internal.SIO ghc-options: -Wall test-suite test From ef4178f4c878d328662fd0444a82384acb1ffdc4 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 14 Apr 2022 08:50:41 -0600 Subject: [PATCH 049/113] Add runSIO, changelog, version bump --- yesod-test/ChangeLog.md | 2 +- yesod-test/Yesod/Test/Internal/SIO.hs | 46 +++++++++++++++++++++++---- yesod-test/yesod-test.cabal | 2 +- 3 files changed, 42 insertions(+), 8 deletions(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 03460acc..1f641f2f 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,6 +1,6 @@ # ChangeLog for yesod-test -## TODO +## 1.6.13 * Add `Yesod.Test.Internal.SIO` module to expose the `SIO` type. diff --git a/yesod-test/Yesod/Test/Internal/SIO.hs b/yesod-test/Yesod/Test/Internal/SIO.hs index 5f6df528..1f80deba 100644 --- a/yesod-test/Yesod/Test/Internal/SIO.hs +++ b/yesod-test/Yesod/Test/Internal/SIO.hs @@ -15,7 +15,7 @@ -- This module is internal. Breaking changes to this module will not be -- reflected in the major version of this package. -- --- @since TODO +-- @since 1.6.13 module Yesod.Test.Internal.SIO where import Control.Monad.Trans.Reader (ReaderT (..)) @@ -35,20 +35,54 @@ instance MS.MonadState s (SIO s) 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 (SIO (ReaderT f)) s = newIORef s >>= f +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 (SIO (ReaderT f)) s = do - ref <- newIORef s - f ref - readIORef ref +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) diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 1c93f246..2eb8491d 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.6.12 +version: 1.6.13 license: MIT license-file: LICENSE author: Nubis From 9c0b00190a25eb7d123360605f4cd65c42c6ec13 Mon Sep 17 00:00:00 2001 From: Isaac van Bakel Date: Wed, 20 Apr 2022 12:01:34 +0100 Subject: [PATCH 050/113] Add test of setDescription idempotency Like setTitle, this function should really be idempotent so developers don't add multiple conflicting meta descriptions to the page. Unlike setTitle, the function currently fails its idempotency test. --- yesod-core/test/YesodCoreTest.hs | 2 + yesod-core/test/YesodCoreTest/Meta.hs | 54 +++++++++++++++++++++++++++ yesod-core/yesod-core.cabal | 1 + 3 files changed, 57 insertions(+) create mode 100644 yesod-core/test/YesodCoreTest/Meta.hs diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 591f86a7..8f2b96dc 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -5,6 +5,7 @@ import YesodCoreTest.CleanPath import YesodCoreTest.Exceptions import YesodCoreTest.Widget import YesodCoreTest.Media +import YesodCoreTest.Meta import YesodCoreTest.Links import YesodCoreTest.Header import YesodCoreTest.NoOverloadedStrings @@ -63,3 +64,4 @@ specs = do Ssl.sameSiteSpec Csrf.csrfSpec breadcrumbTest + metaTest diff --git a/yesod-core/test/YesodCoreTest/Meta.hs b/yesod-core/test/YesodCoreTest/Meta.hs new file mode 100644 index 00000000..ed0a0849 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/Meta.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module YesodCoreTest.Meta + ( metaTest + ) where + +import Test.Hspec + +import Yesod.Core +import Network.Wai +import Network.Wai.Test + +data App = App + +mkYesod "App" [parseRoutes| +/title TitleR GET +/desc DescriptionR GET +|] + +instance Yesod App where + +getTitleR :: Handler Html +getTitleR = defaultLayout $ do + setTitle "First title" + setTitle "Second title" + +getDescriptionR :: Handler Html +getDescriptionR = defaultLayout $ do + setDescription "First description" + setDescription "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 "\nSecond title" res + describe "Yesod.Core.Widget.setDescription" $ do + it "is idempotent" $ runner $ do + res <- request defaultRequest + { pathInfo = ["desc"] + } + assertBody "\nSecond description" res + +runner :: Session () -> IO () +runner f = toWaiAppPlain App >>= runSession f diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index d900011c..876a1cdf 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -155,6 +155,7 @@ test-suite tests YesodCoreTest.LiteApp YesodCoreTest.Media YesodCoreTest.MediaData + YesodCoreTest.Meta YesodCoreTest.NoOverloadedStrings YesodCoreTest.NoOverloadedStringsSub YesodCoreTest.ParameterizedSite From b9fbdb3950d60e74114adb3d1c8edb321cbb5f3a Mon Sep 17 00:00:00 2001 From: Isaac van Bakel Date: Wed, 20 Apr 2022 12:31:49 +0100 Subject: [PATCH 051/113] Add idempotent versions of setDescription API `setDescription` and `setDescriptionI` present a similar API to `setTitle` and `setTitleI`, but unlike those functions the description functions are not idempotent - so calling them multiple times inserts multiple `` tags in HTML ``. This adds explicitly idempotent versions of those functions which are handled in a similar way to the title, so that calling them multiple times has the effect of taking the final value specified. Because the non-idempotent behaviour of setDescription is not obvious, this also adds warnings for that behaviour to make it clear what the effect of multiple calls will be. Unfortunately, setDescriptionIdemp can't be made a drop-in replacement because developers may have defined their own layouts which need to take pageDescription into account. --- yesod-core/src/Yesod/Core/Class/Yesod.hs | 7 ++- yesod-core/src/Yesod/Core/Types.hs | 20 ++++--- yesod-core/src/Yesod/Core/Widget.hs | 74 +++++++++++++++++++----- yesod-core/test/YesodCoreTest/Meta.hs | 8 +-- 4 files changed, 82 insertions(+), 27 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 2a2c1b04..3a3756c6 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -87,6 +87,8 @@ class RenderRoute site => Yesod site where #{pageTitle p} + $maybe description <- pageDescription p + <meta type="description" content="#{description}"> ^{pageHead p} <body> $forall (status, msg) <- msgs @@ -539,8 +541,9 @@ widgetToPageContent w = do { wdRef = ref , wdHandler = hd } - GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref + GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref let title = maybe mempty unTitle mTitle + description = unDescription <$> mDescription scripts = runUniqueList scripts' stylesheets = runUniqueList stylesheets' @@ -610,7 +613,7 @@ widgetToPageContent w = do ^{regularScriptLoad} |] - return $ PageContent title headAll $ + return $ PageContent title description headAll $ case jsLoader master of BottomOfBody -> bodyScript _ -> body diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index 11a55f1a..df95b2d9 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/yesod-core/src/Yesod/Core/Types.hs @@ -289,9 +289,10 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder } -- -- > PageContent url -> HtmlUrl url data PageContent url = PageContent - { pageTitle :: !Html - , pageHead :: !(HtmlUrl url) - , pageBody :: !(HtmlUrl url) + { pageTitle :: !Html + , pageDescription :: !(Maybe Text) + , pageHead :: !(HtmlUrl url) + , pageBody :: !(HtmlUrl url) } data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length. @@ -387,6 +388,7 @@ data Script url = Script { scriptLocation :: !(Location url), scriptAttributes : data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] } deriving (Show, Eq) newtype Title = Title { unTitle :: Html } +newtype Description = Description { unDescription :: Text } newtype Head url = Head (HtmlUrl url) deriving Monoid @@ -402,6 +404,7 @@ type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder data GWData a = GWData { gwdBody :: !(Body a) , gwdTitle :: !(Last Title) + , gwdDescription :: !(Last Description) , gwdScripts :: !(UniqueList (Script a)) , gwdStylesheets :: !(UniqueList (Stylesheet a)) , gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type @@ -409,20 +412,21 @@ data GWData a = GWData , gwdHead :: !(Head a) } instance Monoid (GWData a) where - mempty = GWData mempty mempty mempty mempty mempty mempty mempty + mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif instance Semigroup (GWData a) where - GWData a1 a2 a3 a4 a5 a6 a7 <> - GWData b1 b2 b3 b4 b5 b6 b7 = GWData + GWData a1 a2 a3 a4 a5 a6 a7 a8 <> + GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData (mappend a1 b1) (mappend a2 b2) (mappend a3 b3) (mappend a4 b4) - (unionWith mappend a5 b5) - (mappend a6 b6) + (mappend a5 b5) + (unionWith mappend a6 b6) (mappend a7 b7) + (mappend a8 b8) data HandlerContents = HCContent !H.Status !TypedContent diff --git a/yesod-core/src/Yesod/Core/Widget.hs b/yesod-core/src/Yesod/Core/Widget.hs index 20569790..0e652b79 100644 --- a/yesod-core/src/Yesod/Core/Widget.hs +++ b/yesod-core/src/Yesod/Core/Widget.hs @@ -33,6 +33,8 @@ module Yesod.Core.Widget , setTitleI , setDescription , setDescriptionI + , setDescriptionIdemp + , setDescriptionIdempI , setOGType , setOGImage -- ** CSS @@ -87,19 +89,19 @@ class ToWidget site a where toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidget site (render -> Html) where - toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty + toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty mempty instance render ~ RY site => ToWidget site (render -> Css) where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x instance ToWidget site Css where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidget site (render -> CssBuilder) where - toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty instance ToWidget site CssBuilder where - toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty instance render ~ RY site => ToWidget site (render -> Javascript) where - toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just x) mempty instance ToWidget site Javascript where - toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just $ const x) mempty instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where toWidget = liftWidget instance ToWidget site Html where @@ -130,9 +132,9 @@ instance render ~ RY site => ToWidgetMedia site (render -> Css) where instance ToWidgetMedia site Css where toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where - toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty + toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty instance ToWidgetMedia site CssBuilder where - toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty + toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty class ToWidgetBody site a where toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m () @@ -150,7 +152,7 @@ class ToWidgetHead site a where toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidgetHead site (render -> Html) where - toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head + toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty mempty . Head instance render ~ RY site => ToWidgetHead site (render -> Css) where toWidgetHead = toWidget instance ToWidgetHead site Css where @@ -181,7 +183,7 @@ instance ToWidgetHead site Html where -- * Google typically shows 55-64 characters, so aim to keep your title -- length under 60 characters setTitle :: MonadWidget m => Html -> m () -setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty +setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty -- | Set the localised page title. -- @@ -208,6 +210,14 @@ setDescription :: MonadWidget m => Text -> m () setDescription description = toWidgetHead $ [hamlet|<meta name=description content=#{description}>|] +{-# WARNING setDescription + [ "setDescription is not idempotent; we recommend setDescriptionIdemp instead" + , "Multiple calls to setDescription will insert multiple meta tags in the page head." + , "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \ + \may need to change your layout to include pageDescription." + ] +#-} + -- | Add translated description meta tag to the head of the page -- -- n.b. See comments for @setDescription@. @@ -220,6 +230,44 @@ 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/ +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. +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 @@ -252,7 +300,7 @@ addStylesheetAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m () -addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty +addStylesheetAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty -- | Link to the specified remote stylesheet. addStylesheetRemote :: MonadWidget m => Text -> m () @@ -260,7 +308,7 @@ addStylesheetRemote = flip addStylesheetRemoteAttrs [] -- | Link to the specified remote stylesheet. addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () -addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty +addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty addStylesheetEither :: MonadWidget m => Either (Route (HandlerSite m)) Text @@ -278,7 +326,7 @@ addScript = flip addScriptAttrs [] -- | Link to the specified local script. addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m () -addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty +addScriptAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty -- | Link to the specified remote script. addScriptRemote :: MonadWidget m => Text -> m () @@ -286,7 +334,7 @@ addScriptRemote = flip addScriptRemoteAttrs [] -- | Link to the specified remote script. addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () -addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty +addScriptRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty whamlet :: QuasiQuoter whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings diff --git a/yesod-core/test/YesodCoreTest/Meta.hs b/yesod-core/test/YesodCoreTest/Meta.hs index ed0a0849..6bd9af28 100644 --- a/yesod-core/test/YesodCoreTest/Meta.hs +++ b/yesod-core/test/YesodCoreTest/Meta.hs @@ -32,8 +32,8 @@ getTitleR = defaultLayout $ do getDescriptionR :: Handler Html getDescriptionR = defaultLayout $ do - setDescription "First description" - setDescription "Second description" + setDescriptionIdemp "First description" + setDescriptionIdemp "Second description" metaTest :: Spec metaTest = describe "Setting page metadata" $ do @@ -43,12 +43,12 @@ metaTest = describe "Setting page metadata" $ do { pathInfo = ["title"] } assertBody "<!DOCTYPE html>\n<html><head><title>Second title" res - describe "Yesod.Core.Widget.setDescription" $ do + describe "Yesod.Core.Widget.setDescriptionIdemp" $ do it "is idempotent" $ runner $ do res <- request defaultRequest { pathInfo = ["desc"] } - assertBody "\nSecond description" res + assertBody "\n" res runner :: Session () -> IO () runner f = toWaiAppPlain App >>= runSession f From 04683ca58b771f0d2a214e382b3744419eb7803e Mon Sep 17 00:00:00 2001 From: Isaac van Bakel Date: Wed, 20 Apr 2022 13:01:26 +0100 Subject: [PATCH 052/113] Bump yesod-core version, update ChangeLog --- yesod-core/ChangeLog.md | 8 ++++++++ yesod-core/src/Yesod/Core/Widget.hs | 4 ++++ yesod-core/yesod-core.cabal | 2 +- 3 files changed, 13 insertions(+), 1 deletion(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 94890204..926d3ba2 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,13 @@ # ChangeLog for yesod-core +## 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) diff --git a/yesod-core/src/Yesod/Core/Widget.hs b/yesod-core/src/Yesod/Core/Widget.hs index 0e652b79..0220606a 100644 --- a/yesod-core/src/Yesod/Core/Widget.hs +++ b/yesod-core/src/Yesod/Core/Widget.hs @@ -252,6 +252,8 @@ setDescriptionI msg = do -- 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 @@ -261,6 +263,8 @@ setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Des -- -- 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 () diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 876a1cdf..651bcf1f 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.22.1 +version: 1.6.23 license: MIT license-file: LICENSE author: Michael Snoyman From 1295f1c643c47ff92ef523e9c634d89005b5be6f Mon Sep 17 00:00:00 2001 From: Isaac van Bakel Date: Thu, 21 Apr 2022 14:32:49 +0100 Subject: [PATCH 053/113] Fix typo in how description meta tags are laid out --- yesod-core/src/Yesod/Core/Class/Yesod.hs | 2 +- yesod-core/test/YesodCoreTest/Meta.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 3a3756c6..7a66aa81 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -88,7 +88,7 @@ class RenderRoute site => Yesod site where #{pageTitle p} $maybe description <- pageDescription p - <meta type="description" content="#{description}"> + <meta name="description" content="#{description}"> ^{pageHead p} <body> $forall (status, msg) <- msgs diff --git a/yesod-core/test/YesodCoreTest/Meta.hs b/yesod-core/test/YesodCoreTest/Meta.hs index 6bd9af28..03e6e8ac 100644 --- a/yesod-core/test/YesodCoreTest/Meta.hs +++ b/yesod-core/test/YesodCoreTest/Meta.hs @@ -48,7 +48,7 @@ metaTest = describe "Setting page metadata" $ do res <- request defaultRequest { pathInfo = ["desc"] } - assertBody "<!DOCTYPE html>\n<html><head><title>" res + assertBody "\n" res runner :: Session () -> IO () runner f = toWaiAppPlain App >>= runSession f From 032b906a73e6ce8f4d5eb15a856124d847ac99ae Mon Sep 17 00:00:00 2001 From: Isaac van Bakel Date: Thu, 21 Apr 2022 14:35:22 +0100 Subject: [PATCH 054/113] Bump version to 1.6.23.1, update ChangeLog --- yesod-core/ChangeLog.md | 4 ++++ yesod-core/yesod-core.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 926d3ba2..2c899b82 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-core +## 1.6.23.1 + +* Fix typo in creation of the description `` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766) + ## 1.6.23 * Add idempotent versions of `setDescription`, `setDescriptionI`. These functions diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 651bcf1f..4c0fb52f 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.23 +version: 1.6.23.1 license: MIT license-file: LICENSE author: Michael Snoyman From 28fc2269b03561cc924cdf8ef15ee2263a68f0ba Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 10 May 2022 15:51:18 -0400 Subject: [PATCH 055/113] Fix quote ' not matching in any body This sometimes occured in our code base when generating names with the fakedata package, someone named o'conner randomly fails a particular test. Also add tests for the other matching function and fixed them. Furthermore, I snuck in logging of the matches as well. --- yesod-test/Yesod/Test.hs | 17 ++++++++++++----- yesod-test/test/main.hs | 13 +++++++++++-- yesod-test/yesod-test.cabal | 1 + 3 files changed, 24 insertions(+), 7 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index f2adff40..f6a9de04 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -241,6 +241,8 @@ 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.IO.Class @@ -708,8 +710,13 @@ htmlAllContain query search = do matches <- htmlQuery query case matches of [] -> failure $ "Nothing matched css query: " <> query - _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $ - DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) + _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search ++ " matches: " ++ show matches) $ + DL.all (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches) + +-- | puts the search trough the same escaping as the matches are. +-- this helps with matching on special characters +escape :: String -> String +escape = Blaze.renderMarkup . Blaze.string -- | Queries the HTML using a CSS selector, and passes if any matched -- element contains the given string. @@ -726,8 +733,8 @@ htmlAnyContain query search = do matches <- htmlQuery query case matches of [] -> failure $ "Nothing matched css query: " <> query - _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search) $ - DL.any (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) + _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search ++ " matches: " ++ show matches) $ + DL.any (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches) -- | Queries the HTML using a CSS selector, and fails if any matched -- element contains the given string (in other words, it is the logical @@ -743,7 +750,7 @@ htmlAnyContain query search = do htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site () htmlNoneContain query search = do matches <- htmlQuery query - case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of + case DL.filter (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches) of [] -> return () found -> failure $ "Found " <> T.pack (show $ length found) <> " instances of " <> T.pack search <> " in " <> query <> " elements" diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 16acdf79..808ccf65 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -36,6 +36,7 @@ import Network.Wai.Test (SResponse(simpleBody)) 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 @@ -202,9 +203,17 @@ main = hspec $ do statusIs 200 htmlCount "p" 2 htmlAllContain "p" "Hello" + htmlAllContain "span" "O'Kon" htmlAnyContain "p" "World" htmlAnyContain "p" "Moon" + htmlAnyContain "p" "O'Kon" htmlNoneContain "p" "Sun" + + -- we found it so we know the + -- matching on quotes works for NoneContain + withRunInIO $ \runInIO -> + shouldThrow (runInIO (htmlNoneContain "span" "O'Kon")) + (\case HUnitFailure _ _ -> True) yit "finds the CSRF token by css selector" $ do get ("/form" :: Text) statusIs 200 @@ -221,7 +230,7 @@ main = hspec $ do get ("/htmlWithLink" :: Text) clickOn "a#thelink" statusIs 200 - bodyEquals "Hello

Hello World

Hello Moon

" + bodyEquals "Hello

Hello World

Hello Moon and O'Kon

" get ("/htmlWithLink" :: Text) bad <- tryAny (clickOn "a#nonexistentlink") @@ -555,7 +564,7 @@ app = liteApp $ do FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget onStatic "html" $ dispatchTo $ - return ("Hello

Hello World

Hello Moon

" :: Text) + return ("Hello

Hello World

Hello Moon and O'Kon

" :: Text) onStatic "htmlWithLink" $ dispatchTo $ return ("A linkLink!" :: Text) diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 2eb8491d..84ca6e78 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -41,6 +41,7 @@ library , xml-conduit >= 1.0 , xml-types >= 0.3 , yesod-core >= 1.6.17 + , blaze-markup exposed-modules: Yesod.Test Yesod.Test.CssQuery From 5f3e237c29a0c45f2b0c933d605c5a62ae1ad91e Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 10 May 2022 16:23:17 -0400 Subject: [PATCH 056/113] Bump version and add changes --- yesod-test/ChangeLog.md | 5 +++++ yesod-test/yesod-test.cabal | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 1f641f2f..ea8eede3 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,5 +1,10 @@ # ChangeLog for yesod-test +## 1.6.14 + +* Fix quotes not matching in htmlContain* functions. +* Add logging of the matches found of these functions. + ## 1.6.13 * Add `Yesod.Test.Internal.SIO` module to expose the `SIO` type. diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 84ca6e78..f3ee7dcb 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.6.13 +version: 1.6.14 license: MIT license-file: LICENSE author: Nubis From 8028f1defd85873252231e6020fa08221dcc5a5a Mon Sep 17 00:00:00 2001 From: "Daniel P. Brice" Date: Tue, 10 May 2022 13:24:21 -0700 Subject: [PATCH 057/113] assertEq delegates to HUnit.assertEqual HUnit.assertEqual gives a formatted diff, making it easier to see the differences between the two values at a glance. --- yesod-test/Yesod/Test.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index f2adff40..669596a1 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -544,10 +544,8 @@ htmlQuery = htmlQuery' yedResponse [] -- @since 1.5.2 assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site () assertEq m a b = - liftIO $ HUnit.assertBool msg (a == b) - where msg = "Assertion: " ++ m ++ "\n" ++ - "First argument: " ++ ppShow a ++ "\n" ++ - "Second argument: " ++ ppShow b ++ "\n" + liftIO $ HUnit.assertEqual msg a b + where msg = "Assertion: " ++ m ++ "\n" -- | Asserts that the two given values are not equal. -- From d5a194a7dde7d5fa0abef14baa23004495a1ec68 Mon Sep 17 00:00:00 2001 From: "Daniel P. Brice" Date: Tue, 10 May 2022 13:25:45 -0700 Subject: [PATCH 058/113] Update yesod-test.cabal --- yesod-test/yesod-test.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 2eb8491d..699666cf 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.6.13 +version: 1.6.14 license: MIT license-file: LICENSE author: Nubis From b88b1f430f11d71003d55eb30a3a3b13ba2c6801 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 10 May 2022 16:27:28 -0400 Subject: [PATCH 059/113] Add link to PR --- yesod-test/ChangeLog.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index ea8eede3..8afbf67c 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -2,8 +2,8 @@ ## 1.6.14 -* Fix quotes not matching in htmlContain* functions. -* Add logging of the matches found of these functions. +* 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). ## 1.6.13 From b8de71c5ab0ebda916d41a848bf3390538518f32 Mon Sep 17 00:00:00 2001 From: "Daniel P. Brice" Date: Tue, 10 May 2022 13:31:34 -0700 Subject: [PATCH 060/113] Update ChangeLog.md --- yesod-test/ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 1f641f2f..924ac7d5 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-test +## 1.6.14 + +* 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. From 1487b121be0efc2ef34e4500ee1187eabc66972b Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 6 Jul 2022 21:55:49 +0200 Subject: [PATCH 061/113] Make catching exceptions configurable. Fixes https://github.com/yesodweb/yesod/issues/1771 This is done by adding a function to Yesod typeclass which can match on any exception and tell the framework if it should rethrow or not. I used an overridable function because it seemed more flexible then a whitelist. A user can now for example choose to throw everything, or catch everything as easily. add docs bump --- yesod-core/src/Yesod/Core/Class/Yesod.hs | 20 ++++++++ yesod-core/src/Yesod/Core/Internal/Run.hs | 50 ++++++++++--------- yesod-core/src/Yesod/Core/Types.hs | 13 ++++- .../test/YesodCoreTest/ErrorHandling.hs | 34 +++++++++++++ .../YesodCoreTest/ErrorHandling/CustomApp.hs | 39 +++++++++++++++ yesod-core/yesod-core.cabal | 2 +- 6 files changed, 132 insertions(+), 26 deletions(-) create mode 100644 yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 7a66aa81..78419f82 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -52,8 +52,11 @@ 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, fromException) +import Data.Proxy(Proxy) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. @@ -70,6 +73,17 @@ class RenderRoute site => Yesod site where approot :: Approot site approot = guessApproot + -- | @since 1.6.23.2 + -- Should we catch an exception, or rethrow it. + -- Rethrowing an exception lets the webserver deal with it + -- (usually warp). + -- catching allows yesod to render the error page. + -- the default 'defaultCatchBehavior' is to catch everything + -- (even async), except for the + -- 'Warp.ConnectionClosedByPeer' constructor. + catchBehavior :: Proxy site -> SomeException -> CatchBehavior + catchBehavior _ = defaultCatchBehavior + -- | Output error response pages. -- -- Default value: 'defaultErrorHandler'. @@ -634,6 +648,12 @@ widgetToPageContent w = do runUniqueList :: Eq x => UniqueList x -> [x] runUniqueList (UniqueList x) = nub $ x [] +defaultCatchBehavior :: SomeException -> CatchBehavior +defaultCatchBehavior exception = case fromException exception of + Just Warp.ConnectionClosedByPeer -> Rethrow + _ -> Catch + + -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent defaultErrorHandler NotFound = selectRep $ do diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index c1ffe100..a86c1894 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} module Yesod.Core.Internal.Run ( toErrorHandler , errFromShow @@ -54,6 +55,7 @@ import Yesod.Routes.Class (Route, renderRoute) import Control.DeepSeq (($!!), NFData) import UnliftIO.Exception import UnliftIO(MonadUnliftIO, withRunInIO) +import Data.Proxy(Proxy(..)) -- | like `catch` but doesn't check for async exceptions, -- thereby catching them too. @@ -64,18 +66,15 @@ import UnliftIO(MonadUnliftIO, withRunInIO) -- recovrery from async isn't allowed. -- see async section: https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/ unsafeAsyncCatch - :: (MonadUnliftIO m, Exception e) - => m a -- ^ action - -> (e -> m a) -- ^ handler - -> m a -unsafeAsyncCatch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do - run (g e) - -unsafeAsyncCatchAny :: (MonadUnliftIO m) - => m a -- ^ action + :: (MonadUnliftIO m) + => (SomeException -> CatchBehavior) + -> m a -- ^ action -> (SomeException -> m a) -- ^ handler -> m a -unsafeAsyncCatchAny = unsafeAsyncCatch +unsafeAsyncCatch catchBehavior f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do + case catchBehavior e of + Catch -> run (g e) + Rethrow -> liftIO $ throwIO e -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse @@ -108,7 +107,7 @@ basicRunHandler rhe handler yreq resState = do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ - contents' <- unsafeAsyncCatch + contents' <- unsafeAsyncCatch (rheShouldCatch rhe) (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) @@ -212,10 +211,11 @@ handleContents handleError' finalSession headers contents = -- -- Note that this also catches async exceptions. evalFallback :: (Monoid w, NFData w) - => HandlerContents + => (SomeException -> CatchBehavior) + -> HandlerContents -> w -> IO (w, HandlerContents) -evalFallback contents val = unsafeAsyncCatchAny +evalFallback shouldCatch contents val = unsafeAsyncCatch shouldCatch (fmap (, contents) (evaluate $!! val)) (fmap ((mempty, ) . HCError) . toErrorHandler) @@ -231,8 +231,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState - -- Evaluate the unfortunately-lazy session and headers, -- propagating exceptions into the contents - (finalSession, contents1) <- evalFallback contents0 (ghsSession state) - (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) []) + (finalSession, contents1) <- evalFallback rheShouldCatch contents0 (ghsSession state) + (headers, contents2) <- evalFallback rheShouldCatch contents1 (appEndo (ghsHeaders state) []) contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler) -- Convert the HandlerContents into the final YesodResponse @@ -275,7 +275,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 :: (Yesod site, MonadIO m) => +runFakeHandler :: forall site m a . (Yesod site, MonadIO m) => SessionMap -> (site -> Logger) -> site @@ -296,6 +296,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler , rheMaxExpires = maxExpires + , rheShouldCatch = catchBehavior (Proxy :: Proxy site) } handler' errHandler err req = do @@ -337,7 +338,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do _ <- runResourceT $ yapp fakeRequest I.readIORef ret -yesodRunner :: (ToTypedContent res, Yesod site) +yesodRunner :: forall res site . (ToTypedContent res, Yesod site) => HandlerFor site res -> YesodRunnerEnv site -> Maybe (Route site) @@ -372,6 +373,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do , rheLog = log' , rheOnError = safeEh log' , rheMaxExpires = maxExpires + , rheShouldCatch = catchBehavior (Proxy :: Proxy site) } rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index df95b2d9..bcf3b96e 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/yesod-core/src/Yesod/Core/Types.hs @@ -55,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 (..)) +import UnliftIO (MonadUnliftIO (..), SomeException) -- Sessions type SessionMap = Map Text ByteString @@ -169,6 +169,13 @@ newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } -- @since 1.4.34 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application } +-- | @since 1.6.23.2 +data CatchBehavior = Rethrow -- ^ Rethrow an exception and let the webserver deal with it (usually warp) + | Catch -- ^ catch an exception and render in yesod + + +-- defaultShouldCatch = pure () + data RunHandlerEnv child site = RunHandlerEnv { rheRender :: !(Route site -> [(Text, Text)] -> Text) , rheRoute :: !(Maybe (Route child)) @@ -182,6 +189,10 @@ data RunHandlerEnv child site = RunHandlerEnv -- -- Since 1.2.0 , rheMaxExpires :: !Text + + -- | @since 1.6.23.2 + -- should we catch an exception, or rethrow it. + , rheShouldCatch :: !(SomeException -> CatchBehavior) } data HandlerData child site = HandlerData diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 0995cd62..68680ffe 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} + module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget @@ -23,6 +25,8 @@ 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 @@ -52,6 +56,7 @@ mkYesod "App" [parseRoutes| /only-plain-text OnlyPlainTextR GET /thread-killed ThreadKilledR GET +/connection-closed-by-peer ConnectionClosedPeerR GET /async-session AsyncSessionR GET |] @@ -126,6 +131,12 @@ getThreadKilledR = do liftIO $ Async.withAsync (Conc.killThread x) Async.wait pure "unreachablle" + +getConnectionClosedPeerR :: Handler Html +getConnectionClosedPeerR = + liftIO $ E.throwIO Warp.ConnectionClosedByPeer + + getAsyncSessionR :: Handler Html getAsyncSessionR = do setSession "jap" $ foldMap (pack . show) [0..999999999999999999999999] -- it's going to take a while to figure this one out @@ -179,6 +190,8 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do it "accept image, non-existent path -> 404" caseImageNotFound it "accept video, bad method -> 405" caseVideoBadMethod it "thread killed = 500" caseThreadKilled500 + it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows + it "custom config rethrows an exception" caseCustomExceptionRethrows it "async session exception = 500" asyncSessionKilled500 runner :: Session a -> IO a @@ -324,6 +337,27 @@ caseThreadKilled500 = runner $ do assertStatus 500 res assertBodyContains "Internal Server Error" res +caseDefaultConnectionCloseRethrows :: IO () +caseDefaultConnectionCloseRethrows = + shouldThrow testcode $ \case 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 + + asyncSessionKilled500 :: IO () asyncSessionKilled500 = runner $ do res <- request defaultRequest { pathInfo = ["async-session"] } diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs new file mode 100644 index 00000000..ed0ce972 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs @@ -0,0 +1,39 @@ +{-# 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 + catchBehavior _ exception = + case E.fromException exception of + Just MkMyException -> Rethrow + Nothing -> Catch diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 4c0fb52f..756d71ec 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.23.1 +version: 1.6.23.2 license: MIT license-file: LICENSE author: Michael Snoyman From 827d9269b04fced5c5e552b261e97ab935929f9f Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 6 Jul 2022 22:41:52 +0200 Subject: [PATCH 062/113] update changelog --- yesod-core/ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 2c899b82..917fa5a0 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-core +## 1.6.23.2 + +* Make catching exceptions configurable [#1772](https://github.com/yesodweb/yesod/pull/1772). + ## 1.6.23.1 * Fix typo in creation of the description `` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766) From 9648ccf79f13e381a7cc371719b177b771074ed3 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 6 Jul 2022 22:43:19 +0200 Subject: [PATCH 063/113] add customapp to core.cabal --- yesod-core/yesod-core.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 756d71ec..d7b4b929 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -146,6 +146,7 @@ test-suite tests YesodCoreTest.Header YesodCoreTest.Csrf YesodCoreTest.ErrorHandling + YesodCoreTest.ErrorHandling.CustomApp YesodCoreTest.Exceptions YesodCoreTest.InternalRequest YesodCoreTest.JsLoader From 710adc7329ec99de854be5d4db3b1064e0bfa856 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Thu, 7 Jul 2022 11:15:40 +0200 Subject: [PATCH 064/113] don't patch but minor version bump isntead --- yesod-core/ChangeLog.md | 2 +- yesod-core/src/Yesod/Core/Class/Yesod.hs | 2 +- yesod-core/src/Yesod/Core/Types.hs | 4 ++-- yesod-core/yesod-core.cabal | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 917fa5a0..197dd2c0 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,6 +1,6 @@ # ChangeLog for yesod-core -## 1.6.23.2 +## 1.6.24.0 * Make catching exceptions configurable [#1772](https://github.com/yesodweb/yesod/pull/1772). diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 78419f82..e205ba7a 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -73,7 +73,7 @@ class RenderRoute site => Yesod site where approot :: Approot site approot = guessApproot - -- | @since 1.6.23.2 + -- | @since 1.6.24.0 -- Should we catch an exception, or rethrow it. -- Rethrowing an exception lets the webserver deal with it -- (usually warp). diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index bcf3b96e..c93dc2d6 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/yesod-core/src/Yesod/Core/Types.hs @@ -169,7 +169,7 @@ newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } -- @since 1.4.34 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application } --- | @since 1.6.23.2 +-- | @since 1.6.24.0 data CatchBehavior = Rethrow -- ^ Rethrow an exception and let the webserver deal with it (usually warp) | Catch -- ^ catch an exception and render in yesod @@ -190,7 +190,7 @@ data RunHandlerEnv child site = RunHandlerEnv -- Since 1.2.0 , rheMaxExpires :: !Text - -- | @since 1.6.23.2 + -- | @since 1.6.24.0 -- should we catch an exception, or rethrow it. , rheShouldCatch :: !(SomeException -> CatchBehavior) } diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index d7b4b929..e99d0337 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.23.2 +version: 1.6.24.0 license: MIT license-file: LICENSE author: Michael Snoyman From 27042c93ce532cad9b8b699d2778dc828091f78e Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Thu, 7 Jul 2022 12:06:56 +0200 Subject: [PATCH 065/113] change catchbehavior to get app be in io, make it abstract type --- yesod-core/src/Yesod/Core/CatchBehavior.hs | 23 +++++++++++++++++++ yesod-core/src/Yesod/Core/Class/Yesod.hs | 17 +++++++++----- yesod-core/src/Yesod/Core/Internal/Run.hs | 16 +++++++------ yesod-core/src/Yesod/Core/Types.hs | 10 ++------ .../test/YesodCoreTest/ErrorHandling.hs | 11 +++++---- .../YesodCoreTest/ErrorHandling/CustomApp.hs | 7 +++--- yesod-core/yesod-core.cabal | 1 + 7 files changed, 57 insertions(+), 28 deletions(-) create mode 100644 yesod-core/src/Yesod/Core/CatchBehavior.hs diff --git a/yesod-core/src/Yesod/Core/CatchBehavior.hs b/yesod-core/src/Yesod/Core/CatchBehavior.hs new file mode 100644 index 00000000..6965239c --- /dev/null +++ b/yesod-core/src/Yesod/Core/CatchBehavior.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE LambdaCase #-} + +-- | module providing an abstract type around 'CatchBehavior' +-- through smart constructors. +-- providing future additional extensibility. +-- +-- @since 1.6.24.0 +module Yesod.Core.CatchBehavior(CatchBehavior, rethrow, catch, isCatch) where + +-- | @since 1.6.24.0 +data CatchBehavior = Rethrow -- ^ Rethrow an exception and let the webserver deal with it (usually warp) + | Catch -- ^ catch an exception and render in yesod + +rethrow :: CatchBehavior +rethrow = Rethrow + +catch :: CatchBehavior +catch = Catch + +isCatch :: CatchBehavior -> Bool +isCatch = \case + Catch -> True + Rethrow -> False diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index e205ba7a..5e6538b6 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -55,8 +55,9 @@ import Data.CaseInsensitive (CI) import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Request import Data.IORef -import UnliftIO (SomeException, fromException) +import UnliftIO (SomeException, fromException, isSyncException, fromExceptionUnwrap) import Data.Proxy(Proxy) +import Yesod.Core.CatchBehavior -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. @@ -81,8 +82,8 @@ class RenderRoute site => Yesod site where -- the default 'defaultCatchBehavior' is to catch everything -- (even async), except for the -- 'Warp.ConnectionClosedByPeer' constructor. - catchBehavior :: Proxy site -> SomeException -> CatchBehavior - catchBehavior _ = defaultCatchBehavior + catchBehavior :: site -> SomeException -> IO CatchBehavior + catchBehavior _ = pure . defaultCatchBehavior -- | Output error response pages. -- @@ -648,10 +649,14 @@ widgetToPageContent w = do runUniqueList :: Eq x => UniqueList x -> [x] runUniqueList (UniqueList x) = nub $ x [] +rethrowAsync :: SomeException -> CatchBehavior +rethrowAsync exception = + if isSyncException exception then catch else rethrow + defaultCatchBehavior :: SomeException -> CatchBehavior -defaultCatchBehavior exception = case fromException exception of - Just Warp.ConnectionClosedByPeer -> Rethrow - _ -> Catch +defaultCatchBehavior exception = case fromExceptionUnwrap exception of + Just Warp.ConnectionClosedByPeer -> rethrow + _ -> catch -- | The default error handler for 'errorHandler'. diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index a86c1894..0f444155 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -56,6 +56,7 @@ import Control.DeepSeq (($!!), NFData) import UnliftIO.Exception import UnliftIO(MonadUnliftIO, withRunInIO) import Data.Proxy(Proxy(..)) +import Yesod.Core.CatchBehavior -- | like `catch` but doesn't check for async exceptions, -- thereby catching them too. @@ -67,14 +68,15 @@ import Data.Proxy(Proxy(..)) -- see async section: https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/ unsafeAsyncCatch :: (MonadUnliftIO m) - => (SomeException -> CatchBehavior) + => (SomeException -> IO CatchBehavior) -> m a -- ^ action -> (SomeException -> m a) -- ^ handler -> m a unsafeAsyncCatch catchBehavior f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do - case catchBehavior e of - Catch -> run (g e) - Rethrow -> liftIO $ throwIO e + caught <- liftIO $ catchBehavior e + if isCatch caught + then run (g e) + else liftIO $ EUnsafe.throwIO e -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse @@ -211,7 +213,7 @@ handleContents handleError' finalSession headers contents = -- -- Note that this also catches async exceptions. evalFallback :: (Monoid w, NFData w) - => (SomeException -> CatchBehavior) + => (SomeException -> IO CatchBehavior) -> HandlerContents -> w -> IO (w, HandlerContents) @@ -296,7 +298,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler , rheMaxExpires = maxExpires - , rheShouldCatch = catchBehavior (Proxy :: Proxy site) + , rheShouldCatch = catchBehavior site } handler' errHandler err req = do @@ -373,7 +375,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do , rheLog = log' , rheOnError = safeEh log' , rheMaxExpires = maxExpires - , rheShouldCatch = catchBehavior (Proxy :: Proxy site) + , rheShouldCatch = catchBehavior yreSite } rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index c93dc2d6..84925767 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/yesod-core/src/Yesod/Core/Types.hs @@ -56,6 +56,7 @@ import Control.DeepSeq (NFData (rnf)) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) import Control.Monad.Logger (MonadLoggerIO (..)) import UnliftIO (MonadUnliftIO (..), SomeException) +import Yesod.Core.CatchBehavior -- Sessions type SessionMap = Map Text ByteString @@ -169,13 +170,6 @@ newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } -- @since 1.4.34 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application } --- | @since 1.6.24.0 -data CatchBehavior = Rethrow -- ^ Rethrow an exception and let the webserver deal with it (usually warp) - | Catch -- ^ catch an exception and render in yesod - - --- defaultShouldCatch = pure () - data RunHandlerEnv child site = RunHandlerEnv { rheRender :: !(Route site -> [(Text, Text)] -> Text) , rheRoute :: !(Maybe (Route child)) @@ -192,7 +186,7 @@ data RunHandlerEnv child site = RunHandlerEnv -- | @since 1.6.24.0 -- should we catch an exception, or rethrow it. - , rheShouldCatch :: !(SomeException -> CatchBehavior) + , rheShouldCatch :: !(SomeException -> IO CatchBehavior) } data HandlerData child site = HandlerData diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 68680ffe..15f660c1 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -133,8 +133,10 @@ getThreadKilledR = do getConnectionClosedPeerR :: Handler Html -getConnectionClosedPeerR = - liftIO $ E.throwIO Warp.ConnectionClosedByPeer +getConnectionClosedPeerR = do + x <- liftIO Conc.myThreadId + liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait + pure "unreachablle" getAsyncSessionR :: Handler Html @@ -339,8 +341,9 @@ caseThreadKilled500 = runner $ do caseDefaultConnectionCloseRethrows :: IO () caseDefaultConnectionCloseRethrows = - shouldThrow testcode $ \case Warp.ConnectionClosedByPeer -> True - _ -> False + shouldThrow testcode $ \e -> case E.fromExceptionUnwrap e of + Just Warp.ConnectionClosedByPeer -> True + _ -> False where diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs index ed0ce972..d55df593 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs @@ -15,6 +15,7 @@ module YesodCoreTest.ErrorHandling.CustomApp ) where +import Yesod.Core.CatchBehavior import Yesod.Core.Types import Yesod.Core import qualified UnliftIO.Exception as E @@ -33,7 +34,7 @@ data MyException = MkMyException deriving (Show, E.Exception) instance Yesod CustomApp where - catchBehavior _ exception = + catchBehavior _ exception = pure $ case E.fromException exception of - Just MkMyException -> Rethrow - Nothing -> Catch + Just MkMyException -> rethrow + Nothing -> catch diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index e99d0337..d1a20b25 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -75,6 +75,7 @@ library Yesod.Core.Types Yesod.Core.Unsafe Yesod.Routes.TH.Types + Yesod.Core.CatchBehavior other-modules: Yesod.Core.Internal.Session Yesod.Core.Internal.Request Yesod.Core.Class.Handler From 964fa0db5521f946da68c46225d74e4e2aa93a12 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Thu, 14 Jul 2022 21:52:06 +0200 Subject: [PATCH 066/113] Fix dealing with timeout and add appropriate test add comments for this nonobvious test --- yesod-core/src/Yesod/Core/Class/Yesod.hs | 15 ++++++++++----- yesod-core/test/YesodCoreTest/ErrorHandling.hs | 15 +++++++++++++++ 2 files changed, 25 insertions(+), 5 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 5e6538b6..dd79ae20 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Yesod.Core.Class.Yesod where import Yesod.Core.Content @@ -58,6 +60,7 @@ import Data.IORef import UnliftIO (SomeException, fromException, isSyncException, fromExceptionUnwrap) import Data.Proxy(Proxy) import Yesod.Core.CatchBehavior +import System.Timeout(Timeout) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. @@ -656,7 +659,9 @@ rethrowAsync exception = defaultCatchBehavior :: SomeException -> CatchBehavior defaultCatchBehavior exception = case fromExceptionUnwrap exception of Just Warp.ConnectionClosedByPeer -> rethrow - _ -> catch + _ -> case fromExceptionUnwrap exception of + Just (_ :: Timeout) -> rethrow + _ -> catch -- | The default error handler for 'errorHandler'. diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 15f660c1..27853b38 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -30,6 +30,7 @@ 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 @@ -58,6 +59,7 @@ mkYesod "App" [parseRoutes| /thread-killed ThreadKilledR GET /connection-closed-by-peer ConnectionClosedPeerR GET /async-session AsyncSessionR GET +/sleep-sec SleepASecR GET |] overrideStatus :: Status @@ -131,6 +133,10 @@ getThreadKilledR = do 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 @@ -195,6 +201,7 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows it "custom config rethrows an exception" caseCustomExceptionRethrows it "async session exception = 500" asyncSessionKilled500 + it "can timeout a runner" canTimeoutARunner runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f @@ -366,3 +373,11 @@ asyncSessionKilled500 = runner $ do res <- request defaultRequest { pathInfo = ["async-session"] } assertStatus 500 res assertBodyContains "Internal Server Error" res + +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. From d04c22e3d6d7bdc1933904a30a6c7d095b5ffe98 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 20 Jul 2022 11:55:44 +0200 Subject: [PATCH 067/113] Rewrite default behavior into rethrow async exceptions --- yesod-core/src/Yesod/Core/Class/Yesod.hs | 15 ++----- .../test/YesodCoreTest/ErrorHandling.hs | 39 ++++++------------- 2 files changed, 15 insertions(+), 39 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index dd79ae20..62d182ca 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -82,11 +82,10 @@ class RenderRoute site => Yesod site where -- Rethrowing an exception lets the webserver deal with it -- (usually warp). -- catching allows yesod to render the error page. - -- the default 'defaultCatchBehavior' is to catch everything - -- (even async), except for the - -- 'Warp.ConnectionClosedByPeer' constructor. + -- the default 'rethrowAsync' is to rethrow async + -- exceptions. catchBehavior :: site -> SomeException -> IO CatchBehavior - catchBehavior _ = pure . defaultCatchBehavior + catchBehavior _ = pure . rethrowAsync -- | Output error response pages. -- @@ -656,14 +655,6 @@ rethrowAsync :: SomeException -> CatchBehavior rethrowAsync exception = if isSyncException exception then catch else rethrow -defaultCatchBehavior :: SomeException -> CatchBehavior -defaultCatchBehavior exception = case fromExceptionUnwrap exception of - Just Warp.ConnectionClosedByPeer -> rethrow - _ -> case fromExceptionUnwrap exception of - Just (_ :: Timeout) -> rethrow - _ -> catch - - -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent defaultErrorHandler NotFound = selectRep $ do diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 27853b38..30b22e89 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -18,7 +18,7 @@ import Network.Wai import Network.Wai.Test import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 -import Control.Exception (SomeException, try) +import Control.Exception (SomeException, try, AsyncException(..)) import UnliftIO.Exception(finally) import Network.HTTP.Types (Status, mkStatus) import Data.ByteString.Builder (Builder, toLazyByteString) @@ -58,7 +58,6 @@ mkYesod "App" [parseRoutes| /thread-killed ThreadKilledR GET /connection-closed-by-peer ConnectionClosedPeerR GET -/async-session AsyncSessionR GET /sleep-sec SleepASecR GET |] @@ -132,7 +131,6 @@ 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 @@ -144,16 +142,6 @@ getConnectionClosedPeerR = do liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait pure "unreachablle" - -getAsyncSessionR :: Handler Html -getAsyncSessionR = do - setSession "jap" $ foldMap (pack . show) [0..999999999999999999999999] -- it's going to take a while to figure this one out - x <- liftIO Conc.myThreadId - liftIO $ forkIO $ do - liftIO $ Conc.threadDelay 100000 - Conc.killThread x - pure "reachable" - getErrorR :: Int -> Handler () getErrorR 1 = setSession undefined "foo" getErrorR 2 = setSession "foo" undefined @@ -197,10 +185,9 @@ 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 "thread killed = 500" caseThreadKilled500 it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows it "custom config rethrows an exception" caseCustomExceptionRethrows - it "async session exception = 500" asyncSessionKilled500 + it "thread killed rethrow" caseThreadKilledRethrow it "can timeout a runner" canTimeoutARunner runner :: Session a -> IO a @@ -340,11 +327,16 @@ caseVideoBadMethod = runner $ do } assertStatus 405 res -caseThreadKilled500 :: IO () -caseThreadKilled500 = runner $ do - res <- request defaultRequest { pathInfo = ["thread-killed"] } - assertStatus 500 res - assertBodyContains "Internal Server Error" res +caseThreadKilledRethrow :: IO () +caseThreadKilledRethrow = + shouldThrow testcode $ \e -> case E.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 = @@ -353,7 +345,6 @@ caseDefaultConnectionCloseRethrows = _ -> False where - testcode = runner $ do _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] } pure () @@ -368,12 +359,6 @@ caseCustomExceptionRethrows = customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f -asyncSessionKilled500 :: IO () -asyncSessionKilled500 = runner $ do - res <- request defaultRequest { pathInfo = ["async-session"] } - assertStatus 500 res - assertBodyContains "Internal Server Error" res - canTimeoutARunner :: IO () canTimeoutARunner = do res <- timeout 1000 $ runner $ do From 5ac65db1bf034e145a8530a6b67014ffae546baf Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 20 Jul 2022 12:32:48 +0200 Subject: [PATCH 068/113] Delete catchbevior and allow a user to provide a catch. By default the one from unliftIO is used. --- yesod-core/src/Yesod/Core/CatchBehavior.hs | 23 ------------------- yesod-core/src/Yesod/Core/Class/Yesod.hs | 13 +++-------- yesod-core/src/Yesod/Core/Internal/Run.hs | 22 +++++------------- yesod-core/src/Yesod/Core/Types.hs | 4 ++-- .../YesodCoreTest/ErrorHandling/CustomApp.hs | 11 +++++---- yesod-core/yesod-core.cabal | 1 - 6 files changed, 17 insertions(+), 57 deletions(-) delete mode 100644 yesod-core/src/Yesod/Core/CatchBehavior.hs diff --git a/yesod-core/src/Yesod/Core/CatchBehavior.hs b/yesod-core/src/Yesod/Core/CatchBehavior.hs deleted file mode 100644 index 6965239c..00000000 --- a/yesod-core/src/Yesod/Core/CatchBehavior.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - --- | module providing an abstract type around 'CatchBehavior' --- through smart constructors. --- providing future additional extensibility. --- --- @since 1.6.24.0 -module Yesod.Core.CatchBehavior(CatchBehavior, rethrow, catch, isCatch) where - --- | @since 1.6.24.0 -data CatchBehavior = Rethrow -- ^ Rethrow an exception and let the webserver deal with it (usually warp) - | Catch -- ^ catch an exception and render in yesod - -rethrow :: CatchBehavior -rethrow = Rethrow - -catch :: CatchBehavior -catch = Catch - -isCatch :: CatchBehavior -> Bool -isCatch = \case - Catch -> True - Rethrow -> False diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 62d182ca..553b11cf 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -57,10 +57,7 @@ import Data.CaseInsensitive (CI) import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Request import Data.IORef -import UnliftIO (SomeException, fromException, isSyncException, fromExceptionUnwrap) -import Data.Proxy(Proxy) -import Yesod.Core.CatchBehavior -import System.Timeout(Timeout) +import UnliftIO (SomeException, catch) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. @@ -84,8 +81,8 @@ class RenderRoute site => Yesod site where -- catching allows yesod to render the error page. -- the default 'rethrowAsync' is to rethrow async -- exceptions. - catchBehavior :: site -> SomeException -> IO CatchBehavior - catchBehavior _ = pure . rethrowAsync + catchBehavior :: site -> IO a -> (SomeException -> IO a) -> IO a + catchBehavior _ = catch -- | Output error response pages. -- @@ -651,10 +648,6 @@ widgetToPageContent w = do runUniqueList :: Eq x => UniqueList x -> [x] runUniqueList (UniqueList x) = nub $ x [] -rethrowAsync :: SomeException -> CatchBehavior -rethrowAsync exception = - if isSyncException exception then catch else rethrow - -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent defaultErrorHandler NotFound = selectRep $ do diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 0f444155..e8c361d2 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -56,27 +56,17 @@ import Control.DeepSeq (($!!), NFData) import UnliftIO.Exception import UnliftIO(MonadUnliftIO, withRunInIO) import Data.Proxy(Proxy(..)) -import Yesod.Core.CatchBehavior --- | like `catch` but doesn't check for async exceptions, --- thereby catching them too. --- This is desirable for letting yesod generate a 500 error page --- rather then warp. --- --- Normally this is VERY dubious. you need to rethrow. --- recovrery from async isn't allowed. --- see async section: https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/ +-- | wraps the provided catch fun in a unliftIO unsafeAsyncCatch :: (MonadUnliftIO m) - => (SomeException -> IO CatchBehavior) + => (IO a -> (SomeException -> IO a) -> IO a) -> m a -- ^ action -> (SomeException -> m a) -- ^ handler -> m a -unsafeAsyncCatch catchBehavior f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do - caught <- liftIO $ catchBehavior e - if isCatch caught - then run (g e) - else liftIO $ EUnsafe.throwIO e +unsafeAsyncCatch catchFun f g = withRunInIO $ \run -> + run f `catchFun` \e -> run (g e) + -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse @@ -213,7 +203,7 @@ handleContents handleError' finalSession headers contents = -- -- Note that this also catches async exceptions. evalFallback :: (Monoid w, NFData w) - => (SomeException -> IO CatchBehavior) + => (forall a. IO a -> (SomeException -> IO a) -> IO a) -> HandlerContents -> w -> IO (w, HandlerContents) diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index 84925767..eb07be47 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/yesod-core/src/Yesod/Core/Types.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} module Yesod.Core.Types where import Data.Aeson (ToJSON) @@ -56,7 +57,6 @@ import Control.DeepSeq (NFData (rnf)) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) import Control.Monad.Logger (MonadLoggerIO (..)) import UnliftIO (MonadUnliftIO (..), SomeException) -import Yesod.Core.CatchBehavior -- Sessions type SessionMap = Map Text ByteString @@ -186,7 +186,7 @@ data RunHandlerEnv child site = RunHandlerEnv -- | @since 1.6.24.0 -- should we catch an exception, or rethrow it. - , rheShouldCatch :: !(SomeException -> IO CatchBehavior) + , rheShouldCatch :: !(forall a. IO a -> (SomeException -> IO a) -> IO a) } data HandlerData child site = HandlerData diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs index d55df593..092ee32e 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs @@ -15,7 +15,6 @@ module YesodCoreTest.ErrorHandling.CustomApp ) where -import Yesod.Core.CatchBehavior import Yesod.Core.Types import Yesod.Core import qualified UnliftIO.Exception as E @@ -34,7 +33,9 @@ data MyException = MkMyException deriving (Show, E.Exception) instance Yesod CustomApp where - catchBehavior _ exception = pure $ - case E.fromException exception of - Just MkMyException -> rethrow - Nothing -> catch + -- something we couldn't do before, rethrow custom exceptions + catchBehavior _ action handler = + action `E.catch` \exception -> do + case E.fromException exception of + Just MkMyException -> E.throwIO MkMyException + Nothing -> handler exception diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index d1a20b25..e99d0337 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -75,7 +75,6 @@ library Yesod.Core.Types Yesod.Core.Unsafe Yesod.Routes.TH.Types - Yesod.Core.CatchBehavior other-modules: Yesod.Core.Internal.Session Yesod.Core.Internal.Request Yesod.Core.Class.Handler From 01ccea46cc88421a1b9c0f3bcd44be6205a1ee86 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 20 Jul 2022 12:40:00 +0200 Subject: [PATCH 069/113] update docs, better names rename catchBehvaior -> catchHandlerExceptions rename shouldCatch -> catchHanlderExceptions --- yesod-core/src/Yesod/Core/Class/Yesod.hs | 16 ++++++++-------- yesod-core/src/Yesod/Core/Internal/Run.hs | 10 +++++----- yesod-core/src/Yesod/Core/Types.hs | 5 +++-- .../YesodCoreTest/ErrorHandling/CustomApp.hs | 2 +- 4 files changed, 17 insertions(+), 16 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 553b11cf..21914468 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -75,14 +75,14 @@ class RenderRoute site => Yesod site where approot = guessApproot -- | @since 1.6.24.0 - -- Should we catch an exception, or rethrow it. - -- Rethrowing an exception lets the webserver deal with it - -- (usually warp). - -- catching allows yesod to render the error page. - -- the default 'rethrowAsync' is to rethrow async - -- exceptions. - catchBehavior :: site -> IO a -> (SomeException -> IO a) -> IO a - catchBehavior _ = catch + -- allows the user to specify how exceptions are cought. + -- by default all async exceptions are thrown and synchronous + -- exceptions render a 500 page. + -- One could override this for example to catch all exceptions + -- aside connection closed by peer to let yesod do more 500 page + -- rendering (instead of warp). + catchHandlerExceptions :: site -> IO a -> (SomeException -> IO a) -> IO a + catchHandlerExceptions _ = catch -- | Output error response pages. -- diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index e8c361d2..c090ba4c 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -99,7 +99,7 @@ basicRunHandler rhe handler yreq resState = do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ - contents' <- unsafeAsyncCatch (rheShouldCatch rhe) + contents' <- unsafeAsyncCatch (rheCatchHandlerExceptions rhe) (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) @@ -223,8 +223,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState - -- Evaluate the unfortunately-lazy session and headers, -- propagating exceptions into the contents - (finalSession, contents1) <- evalFallback rheShouldCatch contents0 (ghsSession state) - (headers, contents2) <- evalFallback rheShouldCatch contents1 (appEndo (ghsHeaders state) []) + (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state) + (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) []) contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler) -- Convert the HandlerContents into the final YesodResponse @@ -288,7 +288,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler , rheMaxExpires = maxExpires - , rheShouldCatch = catchBehavior site + , rheCatchHandlerExceptions = catchHandlerExceptions site } handler' errHandler err req = do @@ -365,7 +365,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do , rheLog = log' , rheOnError = safeEh log' , rheMaxExpires = maxExpires - , rheShouldCatch = catchBehavior yreSite + , rheCatchHandlerExceptions = catchHandlerExceptions yreSite } rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index eb07be47..508f4ad5 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/yesod-core/src/Yesod/Core/Types.hs @@ -185,8 +185,9 @@ data RunHandlerEnv child site = RunHandlerEnv , rheMaxExpires :: !Text -- | @since 1.6.24.0 - -- should we catch an exception, or rethrow it. - , rheShouldCatch :: !(forall a. IO a -> (SomeException -> IO a) -> IO a) + -- catch function for rendering 500 pages on exceptions. + -- by default this is catch from unliftio (rethrows all async exceptions). + , rheCatchHandlerExceptions :: !(forall a. IO a -> (SomeException -> IO a) -> IO a) } data HandlerData child site = HandlerData diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs index 092ee32e..e7e5bde2 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs @@ -34,7 +34,7 @@ data MyException = MkMyException instance Yesod CustomApp where -- something we couldn't do before, rethrow custom exceptions - catchBehavior _ action handler = + catchHandlerExceptions _ action handler = action `E.catch` \exception -> do case E.fromException exception of Just MkMyException -> E.throwIO MkMyException From dc4ee0f92cfa48a5055142ef45f997dbcb08aead Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 20 Jul 2022 14:07:30 +0200 Subject: [PATCH 070/113] remove unsafeAsyncCatch --- yesod-core/src/Yesod/Core/Class/Yesod.hs | 4 ++-- yesod-core/src/Yesod/Core/Internal/Run.hs | 15 ++------------- yesod-core/src/Yesod/Core/Types.hs | 2 +- 3 files changed, 5 insertions(+), 16 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 21914468..18ab351c 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -57,7 +57,7 @@ import Data.CaseInsensitive (CI) import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Request import Data.IORef -import UnliftIO (SomeException, catch) +import UnliftIO (SomeException, catch, MonadUnliftIO) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. @@ -81,7 +81,7 @@ class RenderRoute site => Yesod site where -- One could override this for example to catch all exceptions -- aside connection closed by peer to let yesod do more 500 page -- rendering (instead of warp). - catchHandlerExceptions :: site -> IO a -> (SomeException -> IO a) -> IO a + catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a catchHandlerExceptions _ = catch -- | Output error response pages. diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index c090ba4c..897966f0 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -57,17 +57,6 @@ import UnliftIO.Exception import UnliftIO(MonadUnliftIO, withRunInIO) import Data.Proxy(Proxy(..)) --- | wraps the provided catch fun in a unliftIO -unsafeAsyncCatch - :: (MonadUnliftIO m) - => (IO a -> (SomeException -> IO a) -> IO a) - -> m a -- ^ action - -> (SomeException -> m a) -- ^ handler - -> m a -unsafeAsyncCatch catchFun f g = withRunInIO $ \run -> - run f `catchFun` \e -> run (g e) - - -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse toErrorHandler e0 = handleAny errFromShow $ @@ -99,7 +88,7 @@ basicRunHandler rhe handler yreq resState = do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ - contents' <- unsafeAsyncCatch (rheCatchHandlerExceptions rhe) + contents' <- rheCatchHandlerExceptions rhe (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) @@ -207,7 +196,7 @@ evalFallback :: (Monoid w, NFData w) -> HandlerContents -> w -> IO (w, HandlerContents) -evalFallback shouldCatch contents val = unsafeAsyncCatch shouldCatch +evalFallback catcher contents val = catcher (fmap (, contents) (evaluate $!! val)) (fmap ((mempty, ) . HCError) . toErrorHandler) diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index 508f4ad5..88f01e35 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/yesod-core/src/Yesod/Core/Types.hs @@ -187,7 +187,7 @@ data RunHandlerEnv child site = RunHandlerEnv -- | @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. IO a -> (SomeException -> IO a) -> IO a) + , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m => m a -> (SomeException -> m a) -> m a) } data HandlerData child site = HandlerData From 13db3db1187738caa2d800fd6f430d0646acec77 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 20 Jul 2022 14:14:14 +0200 Subject: [PATCH 071/113] Add backwards compatibility for old unliftio --- yesod-core/test/YesodCoreTest/ErrorHandling.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 30b22e89..0892faf1 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -9,6 +9,7 @@ module YesodCoreTest.ErrorHandling , resourcesApp ) where +import Data.Typeable(cast) import qualified System.Mem as Mem import qualified Control.Concurrent.Async as Async import Control.Concurrent as Conc @@ -327,9 +328,16 @@ caseVideoBadMethod = runner $ do } 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 E.fromExceptionUnwrap e of + shouldThrow testcode $ \e -> case fromExceptionUnwrap e of (Just ThreadKilled) -> True _ -> False where @@ -340,7 +348,7 @@ caseThreadKilledRethrow = caseDefaultConnectionCloseRethrows :: IO () caseDefaultConnectionCloseRethrows = - shouldThrow testcode $ \e -> case E.fromExceptionUnwrap e of + shouldThrow testcode $ \e -> case fromExceptionUnwrap e of Just Warp.ConnectionClosedByPeer -> True _ -> False From dd2ba40873f894176b5ef58d3ddf86f618bb53a2 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 20 Jul 2022 14:30:34 +0200 Subject: [PATCH 072/113] be more explicit in changelog --- yesod-core/ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 197dd2c0..ae2c2295 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -2,7 +2,7 @@ ## 1.6.24.0 -* Make catching exceptions configurable [#1772](https://github.com/yesodweb/yesod/pull/1772). +* 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 From 69df01668ac9acdc329e66e68436d50cda4c7e74 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 20 Jul 2022 15:23:29 +0200 Subject: [PATCH 073/113] Update yesod-core/src/Yesod/Core/Class/Yesod.hs Co-authored-by: patrick brisbin --- yesod-core/src/Yesod/Core/Class/Yesod.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 18ab351c..a5845126 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -78,9 +78,9 @@ class RenderRoute site => Yesod site where -- allows the user to specify how exceptions are cought. -- by default all async exceptions are thrown and synchronous -- exceptions render a 500 page. - -- One could override this for example to catch all exceptions - -- aside connection closed by peer to let yesod do more 500 page - -- rendering (instead of warp). + -- 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 From 25f83fb73d4a92832117a6b7b5ec57d696840afc Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 9 Aug 2022 15:54:46 +0200 Subject: [PATCH 074/113] Add withRadioField a more flexible radio option renderer This re-expresses radioField into the new more flexible function. Which gives an adhoc example on how to use it as well. This function passes the radio input to a callback function to let said function decide how it should be rendered. These changes allow you to make a radio table for example, for selecting some row. bump version number, add @since add note on radioField Update changelog --- yesod-form/ChangeLog.md | 4 +++ yesod-form/Yesod/Form/Fields.hs | 45 +++++++++++++++++++++++++-------- yesod-form/yesod-form.cabal | 2 +- 3 files changed, 40 insertions(+), 11 deletions(-) diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index 9441bc04..ece60512 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-form +## 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 (``) [#1748](https://github.com/yesodweb/yesod/pull/1748) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index f5812d73..7cbd3454 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -49,6 +49,7 @@ module Yesod.Form.Fields , selectFieldListGrouped , radioField , radioFieldList + , withRadioField , checkboxesField , checkboxesFieldList , multiSelectField @@ -530,26 +531,50 @@ checkboxesField ioptlist = (multiSelectField ioptlist) radioField :: (Eq a, RenderMessage site FormMessage) => HandlerFor site (OptionList a) -> Field (HandlerFor site) a -radioField = selectFieldHelper - (\theId _name _attrs inside -> [whamlet| -$newline never -
^{inside} -|]) - (\theId name isSel -> [whamlet| +radioField = withRadioField + (\theId optionWidget -> [whamlet| $newline never