Merge pull request #1728 from NorfairKing/breadcrumb-loop-detector

yesod-core: detect loops in breadcrumbs

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)

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

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

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

yesod-core/test/YesodCoreTest/Breadcrumb.hs

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

yesod-core/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 <michael@snoyman.com>