hablo/src/RSS.hs

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

import Article (Article(..))
import ArticlesList (ArticlesList(..), getArticles)
import qualified ArticlesList (description, path)
import Blog (Blog(urls), Renderer, URLs(..))
import Blog.URL (AbsoluteURL, pathOn)
import Collection (Collection(..), getAll)
import qualified Collection (title)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (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 ((</>), (<.>))
import Text.Blaze.Html (Html)

prolog :: Monad m => m Html
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 :: Monad m => AbsoluteURL -> Article -> m Html
articleItem siteURL (Article (Markdown {path, metadata, title})) =
  item_ $ do
    title_ $ toHtml title
    link_ . toHtml $ pathOn siteURL (path <.> "html")
    pubDate_ . toHtml . rfc822Date $ metadata ! "date"
  where
    rfc822Date =
        formatTime defaultTimeLocale rfc822DateFormat
      . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)

feed :: Renderer m => AbsoluteURL -> ArticlesList -> m Html
feed siteURL al@(ArticlesList {collection}) = do
  prolog
  rss_ [version, content, atom] $ do
    channel_ $ do
      title_ . toHtml =<< Collection.title collection
      link_ . toHtml . pathOn siteURL $ ArticlesList.path al
      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 :: AbsoluteURL -> 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)