{-# 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'
module Hakyll.Web.Feed
    ( FeedConfiguration (..)
    , renderRss
    , renderAtom
    , renderJson
    , renderRssWithTemplates
    , renderAtomWithTemplates
    , renderJsonWithTemplates
    ) where


--------------------------------------------------------------------------------
import           Hakyll.Core.Compiler
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)


--------------------------------------------------------------------------------
rssTemplate :: Template
rssTemplate :: Template
rssTemplate =
    $(makeRelativeToProject ("data" </> "templates" </> "rss.xml")
        >>= embedTemplate)

rssItemTemplate :: Template
rssItemTemplate :: Template
rssItemTemplate =
    $(makeRelativeToProject ("data" </> "templates" </> "rss-item.xml")
        >>= embedTemplate)

atomTemplate :: Template
atomTemplate :: Template
atomTemplate =
    $(makeRelativeToProject ("data" </> "templates" </> "atom.xml")
        >>= embedTemplate)

atomItemTemplate :: Template
atomItemTemplate :: Template
atomItemTemplate =
    $(makeRelativeToProject ("data" </> "templates" </> "atom-item.xml")
        >>= embedTemplate)

jsonTemplate :: Template
jsonTemplate :: Template
jsonTemplate =
    $(makeRelativeToProject ("data" </> "templates" </> "feed.json")
        >>= embedTemplate)

jsonItemTemplate :: Template
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.
      FeedConfiguration -> String
feedTitle       :: String
    , -- | Description of the feed.
      FeedConfiguration -> String
feedDescription :: String
    , -- | Name of the feed author.
      FeedConfiguration -> String
feedAuthorName  :: String
    , -- | Email of the feed author.  Set this to the empty String to leave out
      -- the email address.
      FeedConfiguration -> String
feedAuthorEmail :: String
    , -- | Absolute root URL of the feed site (e.g. @http://jaspervdj.be@)
      FeedConfiguration -> String
feedRoot        :: String
    } deriving (Int -> FeedConfiguration -> ShowS
[FeedConfiguration] -> ShowS
FeedConfiguration -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FeedConfiguration] -> ShowS
$cshowList :: [FeedConfiguration] -> ShowS
show :: FeedConfiguration -> String
$cshow :: FeedConfiguration -> String
showsPrec :: Int -> FeedConfiguration -> ShowS
$cshowsPrec :: Int -> FeedConfiguration -> ShowS
Show, FeedConfiguration -> FeedConfiguration -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FeedConfiguration -> FeedConfiguration -> Bool
$c/= :: FeedConfiguration -> FeedConfiguration -> Bool
== :: FeedConfiguration -> FeedConfiguration -> Bool
$c== :: FeedConfiguration -> FeedConfiguration -> Bool
Eq)


--------------------------------------------------------------------------------
-- | Different types a feed can have.
data FeedType = XmlFeed | JsonFeed
  deriving (Int -> FeedType -> ShowS
[FeedType] -> ShowS
FeedType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FeedType] -> ShowS
$cshowList :: [FeedType] -> ShowS
show :: FeedType -> String
$cshow :: FeedType -> String
showsPrec :: Int -> FeedType -> ShowS
$cshowsPrec :: Int -> FeedType -> ShowS
Show, FeedType -> FeedType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FeedType -> FeedType -> Bool
$c/= :: FeedType -> FeedType -> Bool
== :: FeedType -> FeedType -> Bool
$c== :: FeedType -> FeedType -> Bool
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
-> Template
-> Template
-> FeedConfiguration
-> Context String
-> [Item String]
-> Compiler (Item String)
renderFeed FeedType
feedType Template
feedTpl Template
itemTpl FeedConfiguration
config Context String
itemContext [Item String]
items = do
    [Item String]
protectedItems <-
      case FeedType
feedType of
        FeedType
XmlFeed  -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) (f :: * -> *).
(Monad m, Functor f) =>
ShowS -> f String -> m (f String)
applyFilter ShowS
protectCDATA) [Item String]
items
        FeedType
JsonFeed -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Item String]
items
    let itemDelim :: String
itemDelim = case FeedType
feedType of
          FeedType
XmlFeed  -> String
""
          FeedType
JsonFeed -> String
", "

    Item String
body <- forall a. a -> Compiler (Item a)
makeItem forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a.
String -> Template -> Context a -> [Item a] -> Compiler String
applyJoinTemplateList String
itemDelim Template
itemTpl Context String
itemContext' [Item String]
protectedItems
    forall a. Template -> Context a -> Item a -> Compiler (Item String)
applyTemplate Template
feedTpl Context String
feedContext Item String
body
  where
    applyFilter :: (Monad m,Functor f) => (String -> String) -> f String -> m (f String)
    applyFilter :: forall (m :: * -> *) (f :: * -> *).
(Monad m, Functor f) =>
ShowS -> f String -> m (f String)
applyFilter ShowS
tr f String
str = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
tr f String
str
    protectCDATA :: String -> String
    protectCDATA :: ShowS
protectCDATA = String -> ShowS -> ShowS
replaceAll String
"]]>" (forall a b. a -> b -> a
const String
"]]&gt;")

    itemContext' :: Context String
itemContext' = forall a. Monoid a => [a] -> a
mconcat
        [ forall {a}. Context a -> Context a
escapeDescription Context String
itemContext
        , forall a. String -> String -> Context a
constField String
"root" (FeedConfiguration -> String
feedRoot FeedConfiguration
config)
        , forall a. String -> String -> Context a
constField String
"authorName"  (FeedConfiguration -> String
feedAuthorName FeedConfiguration
config)
        , forall {a}. Context a
emailField
        ]

    feedContext :: Context String
feedContext = forall a. Monoid a => [a] -> a
mconcat
         [ String -> Context String
bodyField  String
"body"
         , forall a. String -> String -> Context a
constField String
"title"       (FeedConfiguration -> String
feedTitle FeedConfiguration
config)
         , forall a. String -> String -> Context a
constField String
"description" (FeedConfiguration -> String
feedDescription FeedConfiguration
config)
         , forall a. String -> String -> Context a
constField String
"authorName"  (FeedConfiguration -> String
feedAuthorName FeedConfiguration
config)
         , forall {a}. Context a
emailField
         , forall a. String -> String -> Context a
constField String
"root"        (FeedConfiguration -> String
feedRoot FeedConfiguration
config)
         , forall a. String -> Context a
urlField   String
"url"
         , forall {a}. Context a
updatedField
         , forall {a}. Context a
missingField
         ]

    -- Take the first "updated" field from all items -- this should be the most
    -- recent.
    updatedField :: Context a
updatedField = forall a. String -> (Item a -> Compiler String) -> Context a
field String
"updated" forall a b. (a -> b) -> a -> b
$ \Item a
_ -> case [Item String]
items of
        []      -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"Unknown"
        (Item String
x : [Item String]
_) -> forall a.
Context a -> String -> [String] -> Item a -> Compiler ContextField
unContext Context String
itemContext' String
"updated" [] Item String
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ContextField
cf -> case ContextField
cf of
            StringField String
s -> forall (m :: * -> *) a. Monad m => a -> m a
return String
s
            ContextField
_             -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Hakyll.Web.Feed.renderFeed: Internal error"

    emailField :: Context a
emailField = case FeedConfiguration -> String
feedAuthorEmail FeedConfiguration
config of
        String
""    -> forall {a}. Context a
missingField
        String
email -> forall a. String -> String -> Context a
constField String
"authorEmail" String
email

    escapeDescription :: Context a -> Context a
escapeDescription = case FeedType
feedType of
        FeedType
XmlFeed  -> forall a. a -> a
id
        FeedType
JsonFeed -> forall a. (String -> Bool) -> ShowS -> Context a -> Context a
mapContextBy (forall a. Eq a => a -> a -> Bool
== String
"description") ShowS
escapeString

--------------------------------------------------------------------------------
-- | Render an RSS feed using given templates with a number of items.
renderRssWithTemplates ::
       Template                -- ^ Feed template
    -> Template                -- ^ Item template
    -> FeedConfiguration       -- ^ Feed configuration
    -> Context String          -- ^ Item context
    -> [Item String]           -- ^ Feed items
    -> Compiler (Item String)  -- ^ Resulting feed
renderRssWithTemplates :: Template
-> Template
-> FeedConfiguration
-> Context String
-> [Item String]
-> Compiler (Item String)
renderRssWithTemplates Template
feedTemplate Template
itemTemplate FeedConfiguration
config Context String
context = FeedType
-> Template
-> Template
-> FeedConfiguration
-> Context String
-> [Item String]
-> Compiler (Item String)
renderFeed
    FeedType
XmlFeed Template
feedTemplate Template
itemTemplate FeedConfiguration
config
    (forall a. String -> Context a -> Context a
makeItemContext String
"%a, %d %b %Y %H:%M:%S UT" Context String
context)


--------------------------------------------------------------------------------
-- | Render an Atom feed using given templates with a number of items.
renderAtomWithTemplates ::
       Template                -- ^ Feed template
    -> Template                -- ^ Item template
    -> FeedConfiguration       -- ^ Feed configuration
    -> Context String          -- ^ Item context
    -> [Item String]           -- ^ Feed items
    -> Compiler (Item String)  -- ^ Resulting feed
renderAtomWithTemplates :: Template
-> Template
-> FeedConfiguration
-> Context String
-> [Item String]
-> Compiler (Item String)
renderAtomWithTemplates Template
feedTemplate Template
itemTemplate FeedConfiguration
config Context String
context = FeedType
-> Template
-> Template
-> FeedConfiguration
-> Context String
-> [Item String]
-> Compiler (Item String)
renderFeed
    FeedType
XmlFeed Template
feedTemplate Template
itemTemplate FeedConfiguration
config
    (forall a. String -> Context a -> Context a
makeItemContext String
"%Y-%m-%dT%H:%M:%SZ" Context String
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 :: Template
-> Template
-> FeedConfiguration
-> Context String
-> [Item String]
-> Compiler (Item String)
renderJsonWithTemplates Template
feedTemplate Template
itemTemplate FeedConfiguration
config Context String
context = FeedType
-> Template
-> Template
-> FeedConfiguration
-> Context String
-> [Item String]
-> Compiler (Item String)
renderFeed
    FeedType
JsonFeed Template
feedTemplate Template
itemTemplate FeedConfiguration
config
    (forall a. String -> Context a -> Context a
makeItemContext String
"%Y-%m-%dT%H:%M:%SZ" Context String
context)


--------------------------------------------------------------------------------
-- | Render an RSS feed with a number of items.
renderRss :: FeedConfiguration       -- ^ Feed configuration
          -> Context String          -- ^ Item context
          -> [Item String]           -- ^ Feed items
          -> Compiler (Item String)  -- ^ Resulting feed
renderRss :: FeedConfiguration
-> Context String -> [Item String] -> Compiler (Item String)
renderRss = Template
-> Template
-> FeedConfiguration
-> Context String
-> [Item String]
-> Compiler (Item String)
renderRssWithTemplates Template
rssTemplate Template
rssItemTemplate


--------------------------------------------------------------------------------
-- | Render an Atom feed with a number of items.
renderAtom :: FeedConfiguration       -- ^ Feed configuration
           -> Context String          -- ^ Item context
           -> [Item String]           -- ^ Feed items
           -> Compiler (Item String)  -- ^ Resulting feed
renderAtom :: FeedConfiguration
-> Context String -> [Item String] -> Compiler (Item String)
renderAtom = Template
-> Template
-> FeedConfiguration
-> Context String
-> [Item String]
-> Compiler (Item String)
renderAtomWithTemplates Template
atomTemplate Template
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 :: FeedConfiguration
-> Context String -> [Item String] -> Compiler (Item String)
renderJson = Template
-> Template
-> FeedConfiguration
-> Context String
-> [Item String]
-> Compiler (Item String)
renderJsonWithTemplates Template
jsonTemplate Template
jsonItemTemplate


--------------------------------------------------------------------------------
-- | Copies @$updated$@ from @$published$@ if it is not already set.
makeItemContext :: String -> Context a -> Context a
makeItemContext :: forall a. String -> Context a -> Context a
makeItemContext String
fmt Context a
context = forall a. Monoid a => [a] -> a
mconcat
    [Context a
context, forall a. String -> String -> Context a
dateField String
"published" String
fmt, forall a. String -> String -> Context a
dateField String
"updated" String
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 :: ShowS
escapeString = forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> ShowS
escapeString' String
""
  where
    escapeString' :: String -> ShowS
    escapeString' :: String -> ShowS
escapeString' [] String
s = String
s
    escapeString' (Char
'"' : String
cs) String
s = String -> ShowS
showString String
"\\\"" (String -> ShowS
escapeString' String
cs String
s)
    escapeString' (Char
'\\' : String
cs) String
s = String -> ShowS
showString String
"\\\\" (String -> ShowS
escapeString' String
cs String
s)
    escapeString' (Char
c : String
cs) String
s
      | Char
c forall a. Ord a => a -> a -> Bool
< Char
' ' = Char -> ShowS
escapeChar Char
c (String -> ShowS
escapeString' String
cs String
s)
      | Bool
otherwise = Char -> ShowS
showChar Char
c (String -> ShowS
escapeString' String
cs String
s)

    escapeChar :: Char -> ShowS
    escapeChar :: Char -> ShowS
escapeChar = String -> ShowS
showString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. PrintfType r => String -> r
printf String
"\\u%04X"