hakyll-4.16.7.0: lib/Hakyll/Web/Feed.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- | A Module that allows easy rendering of RSS feeds.
--
-- The main rendering functions (@renderRss@, @renderAtom@) all assume that
-- you pass the list of items so that the most recent entry in the feed is the
-- first item in the list.
--
-- Also note that the context should have (at least) the following fields to
-- produce a correct feed:
--
-- - @$title$@: Title of the item
--
-- - @$description$@: Description to appear in the feed
--
-- - @$url$@: URL to the item - this is usually set automatically.
--
-- In addition, the posts should be named according to the rules for
-- 'Hakyll.Web.Template.Context.dateField'
--
-- Note that for XML-based feeds (i.e. Atom and RSS) field values are not escaped!
-- However, the default 'renderRss' and 'renderAtom' functions will validate the
-- produced XML. Use the -NoValidate functions instead if you need to skip this
-- validation.
module Hakyll.Web.Feed
( FeedConfiguration (..)
, renderRss
, renderRssNoValidate
, renderAtom
, renderAtomNoValidate
, renderJson
, renderRssWithTemplates
, renderRssWithTemplatesNoValidate
, renderAtomWithTemplates
, renderAtomWithTemplatesNoValidate
, renderJsonWithTemplates
, validateXMLFeed
) where
--------------------------------------------------------------------------------
import Hakyll.Core.Compiler
import Hakyll.Core.Compiler.Internal (compilerThrow)
import Hakyll.Core.Item
import Hakyll.Core.Util.String (replaceAll)
import Hakyll.Web.Template
import Hakyll.Web.Template.Context
import Hakyll.Web.Template.List
--------------------------------------------------------------------------------
import Data.FileEmbed (makeRelativeToProject)
import System.FilePath ((</>))
import Text.Printf (printf)
import Control.Exception (displayException)
import Text.XML (parseText, def)
import qualified Data.Text.Lazy as T
--------------------------------------------------------------------------------
rssTemplate :: Template
rssTemplate =
$(makeRelativeToProject ("data" </> "templates" </> "rss.xml")
>>= embedTemplate)
rssItemTemplate :: Template
rssItemTemplate =
$(makeRelativeToProject ("data" </> "templates" </> "rss-item.xml")
>>= embedTemplate)
atomTemplate :: Template
atomTemplate =
$(makeRelativeToProject ("data" </> "templates" </> "atom.xml")
>>= embedTemplate)
atomItemTemplate :: Template
atomItemTemplate =
$(makeRelativeToProject ("data" </> "templates" </> "atom-item.xml")
>>= embedTemplate)
jsonTemplate :: Template
jsonTemplate =
$(makeRelativeToProject ("data" </> "templates" </> "feed.json")
>>= embedTemplate)
jsonItemTemplate :: Template
jsonItemTemplate =
$(makeRelativeToProject ("data" </> "templates" </> "feed-item.json")
>>= embedTemplate)
--------------------------------------------------------------------------------
-- | This is a data structure to keep the configuration of a feed.
data FeedConfiguration = FeedConfiguration
{ -- | Title of the feed.
feedTitle :: String
, -- | Description of the feed.
feedDescription :: String
, -- | Name of the feed author.
feedAuthorName :: String
, -- | Email of the feed author. Set this to the empty String to leave out
-- the email address.
feedAuthorEmail :: String
, -- | Absolute root URL of the feed site (e.g. @http://jaspervdj.be@)
feedRoot :: String
} deriving (Show, Eq)
--------------------------------------------------------------------------------
-- | Different types a feed can have.
data FeedType = XmlFeed | JsonFeed
deriving (Show, Eq)
--------------------------------------------------------------------------------
-- | Abstract function to render any feed.
renderFeed :: FeedType -- ^ Feed type
-> Template -- ^ Default feed template
-> Template -- ^ Default item template
-> FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Context for the items
-> [Item String] -- ^ Input items
-> Compiler (Item String) -- ^ Resulting item
renderFeed feedType feedTpl itemTpl config itemContext items = do
protectedItems <-
case feedType of
XmlFeed -> mapM (applyFilter protectCDATA) items
JsonFeed -> pure items
let itemDelim = case feedType of
XmlFeed -> ""
JsonFeed -> ", "
body <- makeItem =<< applyJoinTemplateList itemDelim itemTpl itemContext' protectedItems
applyTemplate feedTpl feedContext body
where
applyFilter :: (Monad m,Functor f) => (String -> String) -> f String -> m (f String)
applyFilter tr str = return $ fmap tr str
protectCDATA :: String -> String
protectCDATA = replaceAll "]]>" (const "]]>")
itemContext' = mconcat
[ escapeDescription itemContext
, constField "root" (feedRoot config)
, constField "authorName" (feedAuthorName config)
, emailField
]
feedContext = mconcat
[ bodyField "body"
, constField "title" (feedTitle config)
, constField "description" (feedDescription config)
, constField "authorName" (feedAuthorName config)
, emailField
, constField "root" (feedRoot config)
, urlField "url"
, updatedField
, missingField
]
-- Take the first "updated" field from all items -- this should be the most
-- recent.
updatedField = field "updated" $ \_ -> case items of
[] -> return "Unknown"
(x : _) -> unContext itemContext' "updated" [] x >>= \cf -> case cf of
StringField s -> return s
_ -> fail "Hakyll.Web.Feed.renderFeed: Internal error"
emailField = case feedAuthorEmail config of
"" -> missingField
email -> constField "authorEmail" email
escapeDescription = case feedType of
XmlFeed -> id
JsonFeed -> mapContextBy (== "description") escapeString
--------------------------------------------------------------------------------
-- | Validate that a feed contains only correct XML.
validateXMLFeed :: Item String -> Compiler (Item String)
validateXMLFeed rendered = case parseText def $ T.pack (itemBody rendered) of
Right _ -> pure rendered
Left err -> compilerThrow
["Generated feed contains invalid XML (perhaps you id not escape a metadata field?)",
displayException err]
--------------------------------------------------------------------------------
-- | Render an RSS feed using given templates with a number of items.
--
-- The resulting feed will not be validated. Prefer to use 'renderRssWithTemplates'
-- when possible.
--
-- @since 4.16.7.0
renderRssWithTemplatesNoValidate ::
Template -- ^ Feed template
-> Template -- ^ Item template
-> FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
-> Compiler (Item String) -- ^ Resulting feed
renderRssWithTemplatesNoValidate feedTemplate itemTemplate config context = renderFeed
XmlFeed feedTemplate itemTemplate config
(makeItemContext "%a, %d %b %Y %H:%M:%S UT" context)
--------------------------------------------------------------------------------
-- | Render an RSS feed using given templates with a number of items.
--
-- The resulting RSS feed will be validated automatically.
renderRssWithTemplates ::
Template -- ^ Feed template
-> Template -- ^ Item template
-> FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
-> Compiler (Item String) -- ^ Resulting feed
renderRssWithTemplates feedTemplate itemTemplate config context items =
renderRssWithTemplatesNoValidate feedTemplate itemTemplate config context items
>>= validateXMLFeed
--------------------------------------------------------------------------------
-- | Render an Atom feed using given templates with a number of items.
--
-- The resulting feed will not be validated. Prefer to use 'renderAtomWithTemplates'
-- when possible.
--
-- @since 4.16.7.0
renderAtomWithTemplatesNoValidate ::
Template -- ^ Feed template
-> Template -- ^ Item template
-> FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
-> Compiler (Item String) -- ^ Resulting feed
renderAtomWithTemplatesNoValidate feedTemplate itemTemplate config context items = renderFeed
XmlFeed feedTemplate itemTemplate config
(makeItemContext "%Y-%m-%dT%H:%M:%SZ" context)
items
--------------------------------------------------------------------------------
-- | Render an Atom feed using given templates with a number of items.
--
-- The resulting Atom feed will be validated automatically.
renderAtomWithTemplates ::
Template -- ^ Feed template
-> Template -- ^ Item template
-> FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
-> Compiler (Item String) -- ^ Resulting feed
renderAtomWithTemplates feedTemplate itemTemplate config context items =
renderAtomWithTemplatesNoValidate feedTemplate itemTemplate config context items
>>= validateXMLFeed
--------------------------------------------------------------------------------
-- | Render a JSON feed using given templates with a number of items.
renderJsonWithTemplates ::
Template -- ^ Feed template
-> Template -- ^ Item template
-> FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
-> Compiler (Item String) -- ^ Resulting feed
renderJsonWithTemplates feedTemplate itemTemplate config context = renderFeed
JsonFeed feedTemplate itemTemplate config
(makeItemContext "%Y-%m-%dT%H:%M:%SZ" context)
--------------------------------------------------------------------------------
-- | Render an RSS feed with a number of items.
--
-- The resulting feed will not be validated. Prefer to use 'renderRss'
-- when possible.
--
-- @since 4.16.7.0
renderRssNoValidate :: FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
-> Compiler (Item String) -- ^ Resulting feed
renderRssNoValidate = renderRssWithTemplatesNoValidate rssTemplate rssItemTemplate
--------------------------------------------------------------------------------
-- | Render an RSS feed with a number of items.
--
-- The resulting RSS feed will be validated automatically.
renderRss :: FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
-> Compiler (Item String) -- ^ Resulting feed
renderRss config context items = renderRssNoValidate config context items
>>= validateXMLFeed
--------------------------------------------------------------------------------
-- | Render an Atom feed with a number of items.
--
-- The resulting feed will not be validated. Prefer to use 'renderAtom'
-- when possible.
--
-- @since 4.16.7.0
renderAtomNoValidate :: FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
-> Compiler (Item String) -- ^ Resulting feed
renderAtomNoValidate = renderAtomWithTemplatesNoValidate atomTemplate atomItemTemplate
--------------------------------------------------------------------------------
-- | Render an Atom feed with a number of items.
--
-- The resulting Atom feed will be validated automatically.
renderAtom :: FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
-> Compiler (Item String) -- ^ Resulting feed
renderAtom config context items = renderAtomNoValidate config context items
>>= validateXMLFeed
--------------------------------------------------------------------------------
-- | Render a JSON feed with a number of items.
--
-- Items' bodies will be put into @content_html@ field of the resulting JSON;
-- the @content@ field will not be set.
renderJson :: FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
-> Compiler (Item String) -- ^ Resulting feed
renderJson = renderJsonWithTemplates jsonTemplate jsonItemTemplate
--------------------------------------------------------------------------------
-- | Copies @$updated$@ from @$published$@ if it is not already set.
makeItemContext :: String -> Context a -> Context a
makeItemContext fmt context = mconcat
[context, dateField "published" fmt, dateField "updated" fmt]
--------------------------------------------------------------------------------
-- | Escape the string according to [RFC8259 §7](https://www.rfc-editor.org/rfc/rfc8259#section-7). In other words,
-- * quotation marks and backslashes are prefixed with a backslash
-- * control characters (i.e. 0x00 - 0x1F) are escaped s.t. their
-- hex representation are prefixed with "\u00" (e.g. 0x15 -> \u0015)
-- * the rest of the characters are untouched.
escapeString :: String -> String
escapeString = flip escapeString' ""
where
escapeString' :: String -> ShowS
escapeString' [] s = s
escapeString' ('"' : cs) s = showString "\\\"" (escapeString' cs s)
escapeString' ('\\' : cs) s = showString "\\\\" (escapeString' cs s)
escapeString' (c : cs) s
| c < ' ' = escapeChar c (escapeString' cs s)
| otherwise = showChar c (escapeString' cs s)
escapeChar :: Char -> ShowS
escapeChar = showString . printf "\\u%04X"