packages feed

yesod-core 1.6.22.0 → 1.6.23

raw patch · 8 files changed

+153/−45 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

+ Yesod.Core.Types: Description :: Text -> Description
+ Yesod.Core.Types: [gwdDescription] :: GWData a -> !Last Description
+ Yesod.Core.Types: [pageDescription] :: PageContent url -> !Maybe Text
+ Yesod.Core.Types: [unDescription] :: Description -> Text
+ Yesod.Core.Types: newtype Description
+ Yesod.Core.Widget: [pageDescription] :: PageContent url -> !Maybe Text
+ Yesod.Core.Widget: setDescriptionIdemp :: MonadWidget m => Text -> m ()
+ Yesod.Core.Widget: setDescriptionIdempI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
- Yesod.Core.Types: GWData :: !Body a -> !Last Title -> !UniqueList (Script a) -> !UniqueList (Stylesheet a) -> !Map (Maybe Text) (CssBuilderUrl a) -> !Maybe (JavascriptUrl a) -> !Head a -> GWData a
+ Yesod.Core.Types: GWData :: !Body a -> !Last Title -> !Last Description -> !UniqueList (Script a) -> !UniqueList (Stylesheet a) -> !Map (Maybe Text) (CssBuilderUrl a) -> !Maybe (JavascriptUrl a) -> !Head a -> GWData a
- Yesod.Core.Types: PageContent :: !Html -> !HtmlUrl url -> !HtmlUrl url -> PageContent url
+ Yesod.Core.Types: PageContent :: !Html -> !Maybe Text -> !HtmlUrl url -> !HtmlUrl url -> PageContent url
- Yesod.Core.Widget: PageContent :: !Html -> !HtmlUrl url -> !HtmlUrl url -> PageContent url
+ Yesod.Core.Widget: PageContent :: !Html -> !Maybe Text -> !HtmlUrl url -> !HtmlUrl url -> PageContent url

Files

ChangeLog.md view
@@ -1,5 +1,17 @@ # 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)+ ## 1.6.22.0  * Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745)
src/Yesod/Core/Class/Yesod.hs view
@@ -87,6 +87,8 @@             <html>                 <head>                     <title>#{pageTitle p}+                    $maybe description <- pageDescription p+                      <meta type="description" content="#{description}">                     ^{pageHead p}                 <body>                     $forall (status, msg) <- msgs@@ -539,8 +541,9 @@     { 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 @@             ^{regularScriptLoad}         |] -    return $ PageContent title headAll $+    return $ PageContent title description headAll $         case jsLoader master of             BottomOfBody -> bodyScript             _ -> body
src/Yesod/Core/Types.hs view
@@ -289,9 +289,10 @@ -- -- > 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 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 @@ 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 @@     , 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
src/Yesod/Core/Widget.hs view
@@ -33,6 +33,8 @@     , setTitleI     , setDescription     , setDescriptionI+    , setDescriptionIdemp+    , setDescriptionIdempI     , setOGType     , setOGImage       -- ** CSS@@ -87,19 +89,19 @@     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 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 @@     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 @@ --    * 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 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,48 @@     mr <- getMessageRender     toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|] +{-# WARNING setDescriptionI+  [ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead"+  , "Multiple calls to setDescriptionI will insert multiple meta tags in the page head."+  , "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \+    \may need to change your layout to include pageDescription."+  ]+#-}++-- | Add description meta tag to the head of the page+--+-- Google does not use the description tag as a ranking signal, but the+-- contents of this tag will likely affect your click-through rate since it+-- shows up in search results.+--+-- The average length of the description shown in Google's search results is+-- about 160 characters on desktop, and about 130 characters on mobile, at time+-- of writing.+--+-- Unlike 'setDescription', this version is *idempotent* - calling it multiple+-- times will result in only a single description meta tag in the head.+--+-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/+--+-- @since 1.6.23+setDescriptionIdemp :: MonadWidget m => Text -> m ()+setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty++-- | Add translated description meta tag to the head of the page+--+-- n.b. See comments for @setDescriptionIdemp@.+--+-- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple+-- times will result in only a single description meta tag in the head.+--+-- @since 1.6.23+setDescriptionIdempI+  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)+  => msg -> m ()+setDescriptionIdempI msg = do+    mr <- getMessageRender+    setDescriptionIdemp $ mr msg+ -- | Add OpenGraph type meta tag to the head of the page -- -- See all available OG types here: https://ogp.me/#types@@ -252,7 +304,7 @@                    => 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 +312,7 @@  -- | 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 +330,7 @@  -- | 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 +338,7 @@  -- | 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
test/YesodCoreTest.hs view
@@ -5,6 +5,7 @@ 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 @@       Ssl.sameSiteSpec       Csrf.csrfSpec       breadcrumbTest+      metaTest
test/YesodCoreTest/ErrorHandling.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ViewPatterns #-} module YesodCoreTest.ErrorHandling     ( errorHandlingTest@@ -52,7 +51,6 @@ /args-not-valid ArgsNotValidR POST /only-plain-text OnlyPlainTextR GET -/allocation-limit AlocationLimitR GET /thread-killed ThreadKilledR GET /async-session AsyncSessionR GET |]@@ -121,17 +119,6 @@ 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|-        <p> 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@@ -144,7 +131,7 @@   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" @@ -192,7 +179,6 @@       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 +317,6 @@                 ("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
+ test/YesodCoreTest/Meta.hs view
@@ -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+    setDescriptionIdemp "First description"+    setDescriptionIdemp "Second description"++metaTest :: Spec+metaTest = describe "Setting page metadata" $ do+    describe "Yesod.Core.Widget.setTitle" $ do+        it "is idempotent" $ runner $ do+            res <- request defaultRequest+                        { pathInfo = ["title"]+                        }+            assertBody "<!DOCTYPE html>\n<html><head><title>Second title</title></head><body></body></html>" res+    describe "Yesod.Core.Widget.setDescriptionIdemp" $ do+        it "is idempotent" $ runner $ do+            res <- request defaultRequest+                        { pathInfo = ["desc"]+                        }+            assertBody "<!DOCTYPE html>\n<html><head><title></title><meta type=\"description\" content=\"Second description\"></head><body></body></html>" res++runner :: Session () -> IO ()+runner f = toWaiAppPlain App >>= runSession f
yesod-core.cabal view
@@ -1,5 +1,5 @@ name:            yesod-core-version:         1.6.22.0+version:         1.6.23 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -155,6 +155,7 @@                    YesodCoreTest.LiteApp                    YesodCoreTest.Media                    YesodCoreTest.MediaData+                   YesodCoreTest.Meta                    YesodCoreTest.NoOverloadedStrings                    YesodCoreTest.NoOverloadedStringsSub                    YesodCoreTest.ParameterizedSite