-- | Rules that build the Atom feeds
module MathiasSM.Rules.Feed (processFeeds) where

import Control.Monad (forM_)
import Data.Maybe (fromMaybe)
import Data.Time (Day, defaultTimeLocale, formatTime)
import Hakyll (
    Context,
    FeedConfiguration (..),
    Item (itemBody, itemIdentifier),
    Rules,
    compile,
    create,
    defaultContext,
    field,
    fromFilePath,
    idRoute,
    loadAllSnapshots,
    loadBody,
    mapContext,
    preprocess,
    recentFirst,
    renderAtomWithTemplates,
    route,
    urlField,
    withUrls,
 )
import MathiasSM.CleanURL (cleanIndex)
import MathiasSM.Config (SiteConfig, baseUrl, postSnapshot, postsPattern, resolveTemplate, siteAuthor)
import MathiasSM.Content (Post (..), requirePostOf)
import MathiasSM.Feeds (Feed (..), absoluteUrl, feeds)
import MathiasSM.Yaml.Website (Website (websiteFeed), feedSize)

-- | Builds the Atom feed of every post group: its newest posts, in full
processFeeds :: SiteConfig -> Website -> Rules ()
processFeeds :: SiteConfig -> Website -> Rules ()
processFeeds SiteConfig
cfg Website
website = do
    found <- SiteConfig -> Rules (Either [String] [Feed])
forall (m :: * -> *).
MonadMetadata m =>
SiteConfig -> m (Either [String] [Feed])
feeds SiteConfig
cfg
    let feedSize' = FeedConfig -> Int
feedSize (FeedConfig -> Int) -> FeedConfig -> Int
forall a b. (a -> b) -> a -> b
$ Website -> FeedConfig
websiteFeed Website
website
    case found of
        Left [String]
problems -> IO () -> Rules ()
forall a. IO a -> Rules a
preprocess (IO () -> Rules ()) -> IO () -> Rules ()
forall a b. (a -> b) -> a -> b
$ IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"Invalid feeds:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
problems)
        Right [Feed]
all' -> [Feed] -> (Feed -> Rules ()) -> Rules ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Feed]
all' ((Feed -> Rules ()) -> Rules ()) -> (Feed -> Rules ()) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \Feed
feed ->
            [Identifier] -> Rules () -> Rules ()
create [String -> Identifier
fromFilePath (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ Feed -> String
feedFile Feed
feed] (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
                Routes -> Rules ()
route Routes
idRoute
                Compiler (Item String) -> Rules ()
forall a.
(Binary a, Typeable a, Writable a) =>
Compiler (Item a) -> Rules ()
compile (Compiler (Item String) -> Rules ())
-> Compiler (Item String) -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
                    posts <- [Item String] -> Compiler [Item String]
forall (m :: * -> *) a.
(MonadMetadata m, MonadFail m) =>
[Item a] -> m [Item a]
recentFirst ([Item String] -> Compiler [Item String])
-> Compiler [Item String] -> Compiler [Item String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pattern -> String -> Compiler [Item String]
forall a.
(Binary a, Typeable a) =>
Pattern -> String -> Compiler [Item a]
loadAllSnapshots (SiteConfig -> String -> Pattern
postsPattern SiteConfig
cfg (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$ Feed -> String
feedGroup Feed
feed) (String -> String
postSnapshot (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Feed -> String
feedGroup Feed
feed)
                    feedTemplate <- loadBody (resolveTemplate cfg "atom-feed.xml")
                    itemTemplate <- loadBody (resolveTemplate cfg "atom-item.xml")
                    renderAtomWithTemplates feedTemplate itemTemplate (configuration cfg feed) (itemContext cfg) (take feedSize' posts)

configuration :: SiteConfig -> Feed -> FeedConfiguration
configuration :: SiteConfig -> Feed -> FeedConfiguration
configuration SiteConfig
cfg Feed
feed =
    FeedConfiguration
        { feedTitle :: String
feedTitle = Feed -> String
MathiasSM.Feeds.feedTitle Feed
feed
        , feedDescription :: String
feedDescription = Feed -> String
MathiasSM.Feeds.feedDescription Feed
feed
        , feedAuthorName :: String
feedAuthorName = SiteConfig -> String
siteAuthor SiteConfig
cfg
        , feedAuthorEmail :: String
feedAuthorEmail = String
""
        , feedRoot :: String
feedRoot = SiteConfig -> String
baseUrl SiteConfig
cfg
        }

{- | What each entry reads: its clean URL, its full text with absolute links
(@description@, the feed templates' name for the content), and its dates
-}
itemContext :: SiteConfig -> Context String
itemContext :: SiteConfig -> Context String
itemContext SiteConfig
cfg =
    (String -> String) -> Context String -> Context String
forall a. (String -> String) -> Context a -> Context a
mapContext String -> String
cleanIndex (String -> Context String
forall a. String -> Context a
urlField String
"url")
        Context String -> Context String -> Context String
forall a. Semigroup a => a -> a -> a
<> String -> (Item String -> Compiler String) -> Context String
forall a. String -> (Item a -> Compiler String) -> Context a
field String
"description" (String -> Compiler String
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Compiler String)
-> (Item String -> String) -> Item String -> Compiler String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> String -> String
withUrls (String -> String -> String
absoluteUrl (SiteConfig -> String
baseUrl SiteConfig
cfg)) (String -> String)
-> (Item String -> String) -> Item String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item String -> String
forall a. Item a -> a
itemBody)
        Context String -> Context String -> Context String
forall a. Semigroup a => a -> a -> a
<> String -> (Post -> Day) -> Context String
timestampField String
"published" Post -> Day
postDate
        Context String -> Context String -> Context String
forall a. Semigroup a => a -> a -> a
<> String -> (Post -> Day) -> Context String
timestampField String
"updated" (\Post
post -> Day -> Maybe Day -> Day
forall a. a -> Maybe a -> a
fromMaybe (Post -> Day
postDate Post
post) (Post -> Maybe Day
postLastModified Post
post))
        Context String -> Context String -> Context String
forall a. Semigroup a => a -> a -> a
<> Context String
defaultContext

-- | An RFC 3339 timestamp (midnight UTC) of one of the post's dates
timestampField :: String -> (Post -> Day) -> Context String
timestampField :: String -> (Post -> Day) -> Context String
timestampField String
name Post -> Day
pick = String -> (Item String -> Compiler String) -> Context String
forall a. String -> (Item a -> Compiler String) -> Context a
field String
name ((Item String -> Compiler String) -> Context String)
-> (Item String -> Compiler String) -> Context String
forall a b. (a -> b) -> a -> b
$ \Item String
item ->
    TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT00:00:00Z" (Day -> String) -> (Post -> Day) -> Post -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Post -> Day
pick (Post -> String) -> Compiler Post -> Compiler String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> Compiler Post
requirePostOf (Item String -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item String
item)