Add JSON Feed support (#975)

* Initial JSON Feed support * Specify JSON Feed templates as extra source files * Wrap descriptionJson field with quotes * Escape description field within hakyll itself * Add title to JSON Feed item * Reorganize some code * Add docstring to escapeString * Add mailto URL to the author if email is present * Address review points - Make function names consistent with the rest - Model string escaping logic according to RFC8259 * Format * Make naming more consistent * Fix escaping logic * Update the feed tutorial to include JSON feed * Update the title of feed tutorial * Document that bodies go into `content_html` C.f. #975 (comment) --------- Co-authored-by: Alexander Batischev <[email protected]>
jaspervdj · Aug 6, 2023 · 858af2d · 858af2d
1 parent 416faa8
commit 858af2d
Show file tree

Hide file tree

Showing 6 changed files with 142 additions and 14 deletions.
diff --git a/data/templates/feed-item.json b/data/templates/feed-item.json
@@ -0,0 +1,8 @@
+{
+    "id": "$root$$url$",
+    "url": "$root$$url$",
+    "content_html": "$description$",
+    "title": "$title$",
+    "date_published": "$published$",
+    "date_modified": "$updated$"
+}
diff --git a/data/templates/feed.json b/data/templates/feed.json
@@ -0,0 +1,17 @@
+{
+    "version": "https://www.jsonfeed.org/version/1.1",
+    "title": "$title$",
+    "home_page_url": "$root$",
+    "feed_url": "$root$$url$",
+    $if(authorName)$
+    "authors": [
+        {
+            "name": "$authorName$"
+            $if(authorEmail)$
+            , "url": "mailto:$authorEmail$"
+            $endif$
+        }
+    ],
+    $endif$
+    "items": [ $body$ ]
+}
diff --git a/hakyll.cabal b/hakyll.cabal
@@ -92,6 +92,8 @@ Extra-source-files:
   data/templates/atom.xml
   data/templates/rss-item.xml
   data/templates/rss.xml
+  data/templates/feed.json
+  data/templates/feed-item.json
 
 Source-Repository head
   Type:     git

diff --git a/lib/Hakyll/Web/Feed.hs b/lib/Hakyll/Web/Feed.hs
@@ -23,8 +23,10 @@ module Hakyll.Web.Feed
     ( FeedConfiguration (..)
     , renderRss
     , renderAtom
+    , renderJson
     , renderRssWithTemplates
     , renderAtomWithTemplates
+    , renderJsonWithTemplates
     ) where
 
 
@@ -40,6 +42,7 @@ import           Hakyll.Web.Template.List
 --------------------------------------------------------------------------------
 import           Data.FileEmbed              (makeRelativeToProject)
 import           System.FilePath             ((</>))
+import Text.Printf (printf)
 
 
 --------------------------------------------------------------------------------
@@ -63,6 +66,16 @@ 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.
@@ -81,17 +94,31 @@ data FeedConfiguration = FeedConfiguration
     } deriving (Show, Eq)
 
 
+--------------------------------------------------------------------------------
+-- | Different types a feed can have.
+data FeedType = XmlFeed | JsonFeed
+  deriving (Show, Eq)
+
+
 --------------------------------------------------------------------------------
 -- | Abstract function to render any feed.
-renderFeed :: Template                -- ^ Default feed template
+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 feedTpl itemTpl config itemContext items = do
-    protectedItems <- mapM (applyFilter protectCDATA) items
-    body <- makeItem =<< applyTemplateList itemTpl itemContext' protectedItems
+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)
@@ -100,7 +127,7 @@ renderFeed feedTpl itemTpl config itemContext items = do
     protectCDATA = replaceAll "]]>" (const "]]&gt;")
 
     itemContext' = mconcat
-        [ itemContext
+        [ escapeDescription itemContext
         , constField "root" (feedRoot config)
         , constField "authorName"  (feedAuthorName config)
         , emailField
@@ -130,6 +157,10 @@ renderFeed feedTpl itemTpl config itemContext items = do
         ""    -> missingField
         email -> constField "authorEmail" email
 
+    escapeDescription = case feedType of
+        XmlFeed  -> id
+        JsonFeed -> mapContextBy (== "description") escapeString
+
 --------------------------------------------------------------------------------
 -- | Render an RSS feed using given templates with a number of items.
 renderRssWithTemplates ::
@@ -140,7 +171,7 @@ renderRssWithTemplates ::
     -> [Item String]           -- ^ Feed items
     -> Compiler (Item String)  -- ^ Resulting feed
 renderRssWithTemplates feedTemplate itemTemplate config context = renderFeed
-    feedTemplate itemTemplate config
+    XmlFeed feedTemplate itemTemplate config
     (makeItemContext "%a, %d %b %Y %H:%M:%S UT" context)
 
 
@@ -154,7 +185,21 @@ renderAtomWithTemplates ::
     -> [Item String]           -- ^ Feed items
     -> Compiler (Item String)  -- ^ Resulting feed
 renderAtomWithTemplates feedTemplate itemTemplate config context = renderFeed
-    feedTemplate itemTemplate config
+    XmlFeed feedTemplate itemTemplate config
+    (makeItemContext "%Y-%m-%dT%H:%M:%SZ" context)
+
+
+--------------------------------------------------------------------------------
+-- | 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)
 
 
@@ -176,8 +221,41 @@ renderAtom :: FeedConfiguration       -- ^ Feed configuration
 renderAtom = renderAtomWithTemplates atomTemplate atomItemTemplate
 
 
+--------------------------------------------------------------------------------
+-- | 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"
diff --git a/lib/Hakyll/Web/Template/Context.hs b/lib/Hakyll/Web/Template/Context.hs
@@ -31,6 +31,7 @@ module Hakyll.Web.Template.Context
     , listFieldWith
     , functionField
     , mapContext
+    , mapContextBy
 
     , defaultContext
     , bodyField
@@ -201,11 +202,26 @@ functionField name value = Context $ \k args i ->
 -- > constField "x" "ac" <> constField "y" "bc"
 --
 mapContext :: (String -> String) -> Context a -> Context a
-mapContext f (Context c) = Context $ \k a i -> do
+mapContext = mapContextBy (const True)
+
+
+--------------------------------------------------------------------------------
+-- | Transform the respective string results of all fields in a context
+-- satisfying a predicate. For example,
+--
+-- > mapContextBy (=="y") (++"c") (constField "x" "a" <> constField "y" "b")
+--
+-- is equivalent to
+--
+-- > constField "x" "a" <> constField "y" "bc"
+--
+mapContextBy :: (String -> Bool) -> (String -> String) -> Context a -> Context a
+mapContextBy p f (Context c) = Context $ \k a i -> do
     fld <- c k a i
     case fld of
         EmptyField      -> wrongType "boolField"
-        StringField str -> return $ StringField (f str)
+        StringField str -> return $ StringField $
+                             if p k then f str else str
         _               -> wrongType "ListField"
   where
     wrongType typ = fail $ "Hakyll.Web.Template.Context.mapContext: " ++

diff --git a/web/tutorials/05-snapshots-feeds.markdown b/web/tutorials/05-snapshots-feeds.markdown
@@ -1,13 +1,13 @@
 ---
-title: Snapshots, and how to produce an RSS/Atom feed
+title: Snapshots, and how to produce an RSS/Atom/JSON feed
 author: Jasper Van der Jeugt
 type: main
 ---
 
 Basic feed configuration
 ------------------------
 
-Hakyll has built-in support for two types of feeds: RSS and Atom. This tutorial
+Hakyll has built-in support for three types of feeds: RSS, Atom and JSON. This tutorial
 explains how you can add these to your blog or website. The first step is to
 define a `FeedConfiguration` to set some basic options. For example, a cooking
 blog may have the following declaration:
@@ -26,7 +26,7 @@ myFeedConfiguration = FeedConfiguration
 Simple feed rendering
 ---------------------
 
-Now, let's look at how we actually create a feed. Two functions are available:
+Now, let's look at how we actually create a feed. Three functions are available:
 
 ```haskell
 renderAtom :: FeedConfiguration
@@ -42,8 +42,15 @@ renderRss :: FeedConfiguration
           -> Compiler (Item String)
 ```
 
+```haskell
+renderJson :: FeedConfiguration
+           -> Context String
+           -> [Item String]
+           -> Compiler (Item String)
+```
+
 As you can see, they have exactly the same signature: we're going to use
-`renderAtom` in this tutorial, but it's trivial to change this to an RSS feed.
+`renderAtom` in this tutorial, but it's trivial to change this to an RSS or JSON feed.
 
 ```haskell
 create ["atom.xml"] $ do
@@ -60,7 +67,7 @@ There we go! We simply take the 10 last posts and pass them to `renderAtom`,
 with our configuration and a `Context`.
 
 It's a bit of a problem that we don't have a description for our posts, and the
-Atom/RSS feed renderer requires this. One option is to add a `description: Foo`
+Atom/RSS/JSON feed renderer requires this. One option is to add a `description: Foo`
 header to our all posts. However, the description is the body text as it appears
 in most RSS readers, so we would prefer to include the entire content of the
 posts here.