From d981c87c3994b848cf7b105f2adc5de3362b252e Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Mon, 17 May 2021 20:40:09 +0200 Subject: [PATCH 1/6] yesod-core: detect loops in breadcrumbs --- yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs b/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs index 1e956ff2..34069e7f 100644 --- a/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs +++ b/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Class.Breadcrumbs where import Yesod.Core.Handler @@ -15,7 +16,7 @@ class YesodBreadcrumbs site where -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles. -breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)]) +breadcrumbs :: (YesodBreadcrumbs site, Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)]) breadcrumbs = do x <- getCurrentRoute case x of @@ -28,4 +29,8 @@ breadcrumbs = do go back Nothing = return back go back (Just this) = do (title, next) <- breadcrumb this - go ((this, title) : back) next + if next `elem` (map (Just . fst) back) + then + error $ "infinite recursion in breadcrumbs at" <> show title + else + go ((this, title) : back) next From 96a940b60c2814513017876ab32a79d1a2a530d4 Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Thu, 20 May 2021 14:25:17 +0200 Subject: [PATCH 2/6] yesod-core: test for looping breadcrumbs --- yesod-core/test/YesodCoreTest.hs | 2 + yesod-core/test/YesodCoreTest/Breadcrumb.hs | 58 +++++++++++++++++++++ 2 files changed, 60 insertions(+) create mode 100644 yesod-core/test/YesodCoreTest/Breadcrumb.hs diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index e9f42851..591f86a7 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -12,6 +12,7 @@ import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling import YesodCoreTest.Cache import YesodCoreTest.ParameterizedSite +import YesodCoreTest.Breadcrumb import qualified YesodCoreTest.WaiSubsite as WaiSubsite import qualified YesodCoreTest.Redirect as Redirect import qualified YesodCoreTest.JsLoader as JsLoader @@ -61,3 +62,4 @@ specs = do Ssl.sslOnlySpec Ssl.sameSiteSpec Csrf.csrfSpec + breadcrumbTest diff --git a/yesod-core/test/YesodCoreTest/Breadcrumb.hs b/yesod-core/test/YesodCoreTest/Breadcrumb.hs new file mode 100644 index 00000000..c64cfa25 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/Breadcrumb.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module YesodCoreTest.Breadcrumb + ( breadcrumbTest, + ) +where + +import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.Text (Text) +import Data.Typeable (Typeable) +import Network.Wai +import Network.Wai.Test +import Test.Hspec +import UnliftIO.IORef +import Yesod.Core + +data A = A + +mkYesod + "A" + [parseRoutes| +/ RootR GET +/loop LoopR GET +|] + +instance Yesod A + +instance YesodBreadcrumbs A where + breadcrumb r = case r of + RootR -> pure ("Root", Nothing) + LoopR -> pure ("Loop", Just LoopR) -- Purposefully a loop + +getRootR :: Handler Text +getRootR = fst <$> breadcrumbs + +getLoopR :: Handler Text +getLoopR = fst <$> breadcrumbs + +breadcrumbTest :: Spec +breadcrumbTest = + describe "Test.Breadcrumb" $ do + it "can fetch the root which contains breadcrumbs" $ + runner $ do + res <- request defaultRequest + assertStatus 200 res + it "gets a 500 for a route with a looping breadcrumb" $ + runner $ do + res <- request defaultRequest {pathInfo = ["loop"]} + assertStatus 500 res + +runner :: Session () -> IO () +runner f = toWaiApp A >>= runSession f From 59ef730317d0b29567a16d15688ebf2b4bfc646c Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Thu, 20 May 2021 14:28:09 +0200 Subject: [PATCH 3/6] yesod-core: refactor the loop detector to not use Just wrapping --- yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs b/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs index 34069e7f..8bce0233 100644 --- a/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs +++ b/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs @@ -29,8 +29,8 @@ breadcrumbs = do go back Nothing = return back go back (Just this) = do (title, next) <- breadcrumb this - if next `elem` (map (Just . fst) back) + if this `elem` map fst back then - error $ "infinite recursion in breadcrumbs at" <> show title + error $ "yesod-core: infinite recursion in breadcrumbs at " <> show title else go ((this, title) : back) next From 884d937792402fcd34b474bc60fa3664b27173b9 Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Thu, 20 May 2021 16:00:55 +0200 Subject: [PATCH 4/6] use ++ instead of <> to fix the build --- yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs b/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs index 8bce0233..c1e7b5af 100644 --- a/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs +++ b/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs @@ -31,6 +31,6 @@ breadcrumbs = do (title, next) <- breadcrumb this if this `elem` map fst back then - error $ "yesod-core: infinite recursion in breadcrumbs at " <> show title + error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show title else go ((this, title) : back) next From 0db056534c4efb968249961b08df2c4b1f7873a1 Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Fri, 21 May 2021 08:41:42 +0200 Subject: [PATCH 5/6] breadcrumbs: guard refactor --- yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs b/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs index c1e7b5af..9773af1d 100644 --- a/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs +++ b/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs @@ -16,7 +16,7 @@ class YesodBreadcrumbs site where -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles. -breadcrumbs :: (YesodBreadcrumbs site, Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)]) +breadcrumbs :: (YesodBreadcrumbs site, Show (Route site), Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)]) breadcrumbs = do x <- getCurrentRoute case x of @@ -27,10 +27,8 @@ breadcrumbs = do return (title, z) where go back Nothing = return back - go back (Just this) = do - (title, next) <- breadcrumb this - if this `elem` map fst back - then - error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show title - else + go back (Just this) + | this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this + | otherwise = do + (title, next) <- breadcrumb this go ((this, title) : back) next From 2d0dab20a645be2e2de0eda31b5161897c84fc1e Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Fri, 21 May 2021 17:09:10 +0200 Subject: [PATCH 6/6] minor version bump and changelog entry --- 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 45793963..0a5ed49e 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-core +## 1.6.20.1 + +* Throw an error in `breadcrumbs` if the trail of breadcrumbs is circular. [#1727](https://github.com/yesodweb/yesod/issues/1727) + ## 1.6.20 * Generate CSRF tokens using a secure entropy source [#1726](https://github.com/yesodweb/yesod/pull/1726) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 1c258f15..b22ade9d 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.20 +version: 1.6.20.1 license: MIT license-file: LICENSE author: Michael Snoyman