hablo-1.1.0.1: src/RSS.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module RSS (
    generate
  ) where

import Article (Article(..))
import ArticlesList (ArticlesList(..), getArticles)
import qualified ArticlesList (description)
import Blog (Blog(urls), Renderer, URL(..))
import Collection (Collection(..), getAll)
import qualified Collection (title)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (MonadReader, ReaderT, asks)
import Data.Text (Text)
import Data.Map ((!))
import qualified Data.Text.Lazy.IO as TextIO (writeFile)
import Data.Time (defaultTimeLocale, formatTime, rfc822DateFormat)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Lucid (Attribute, HtmlT, Term, ToHtml(..), term, renderTextT)
import Lucid.Base (makeAttribute)
import Markdown (Markdown(..))
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))

prolog :: Monad m => HtmlT m ()
prolog = toHtmlRaw ("<?xml  version=\"1.0\" encoding=\"UTF-8\" ?>" :: String)

version_ :: Text -> Attribute
version_ = makeAttribute "version"

xmlns_content_ :: Text -> Attribute
xmlns_content_ = makeAttribute "xmlns:content"

xmlns_atom_ :: Text -> Attribute
xmlns_atom_ = makeAttribute "xmlns:atom"

rss_ :: Term arg result => arg -> result
rss_ = term "rss"

channel_ :: Term arg result => arg -> result
channel_ = term "channel"

title_ :: Term arg result => arg -> result
title_ = term "title"

link_ :: Term arg result => arg -> result
link_ = term "link"

description_ :: Term arg result => arg -> result
description_ = term "description"

item_ :: Term arg result => arg -> result
item_ = term "item"

pubDate_ :: Term arg result => arg -> result
pubDate_ = term "pubDate"

articleItem :: MonadReader Blog m => String -> Article -> HtmlT m ()
articleItem siteURL (Article (Markdown {path, metadata, title})) =
  item_ $ do
    title_ $ toHtml title
    link_ $ toHtml (siteURL </> path <.> "html")
    pubDate_ . toHtml . rfc822Date $ metadata ! "date"
  where
    rfc822Date =
        formatTime defaultTimeLocale rfc822DateFormat
      . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)

feed :: Renderer m => String -> ArticlesList -> HtmlT m ()
feed siteURL al@(ArticlesList {collection}) = do
  prolog
  rss_ [version, content, atom] $ do
    channel_ $ do
      title_ . toHtml =<< Collection.title collection
      link_ . toHtml $ siteURL </> maybe "" (++ "/") (tag collection)
      description_ . toHtml =<< ArticlesList.description al
      mapM_ (articleItem siteURL) =<< getArticles al
  where
    version = version_ "2.0"
    content = xmlns_content_ "http://purl.org/rss/1.0/modules/content/"
    atom = xmlns_atom_ "http://www.w3.org/2005/Atom"

generateCollection :: String -> Collection -> ReaderT Blog IO ()
generateCollection siteURL collection =
  renderTextT (feed siteURL $ ArticlesList {full = False, collection})
  >>= liftIO . TextIO.writeFile (basePath collection </> "rss" <.> "xml")

generate :: ReaderT Blog IO ()
generate = (asks $urls.$rss) >>= maybe (return ()) generateAll
  where
    generateAll siteURL = Collection.getAll >>= mapM_ (generateCollection siteURL)