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