Add a RSS module to generate feeds

src/Main.hs

@@ -8,6 +8,7 @@ import Data.Version (showVersion)
 import qualified HTML (generate)
 import qualified JS (generate)
 import qualified Paths_hablo as Hablo (version)
+import qualified RSS (generate)
 import System.Exit (exitSuccess)
 
 main :: IO ()
@@ -18,4 +19,5 @@ main = do
     config@(BlogConfig {}) -> Blog.build config >>= runReaderT (do
         HTML.generate
         JS.generate
+        RSS.generate
       )

src/RSS.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+module RSS (
+    generate
+  ) where
+
+import Article (Article(..))
+import ArticlesList (ArticlesList(..))
+import qualified ArticlesList (description, title)
+import Blog (Blog(..), Path(..), Skin(..), URL(..))
+import Collection (Collection(..), getAll)
+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 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 {key, metadata, title}) =
+  item_ $ do
+    title_ $ toHtml title
+    link_ . toHtml =<< link <$> (asks $path.$articlesPath)
+    pubDate_ . toHtml . rfc822Date $ metadata ! "date"
+  where
+    link path = siteURL </> path </> key <.> "html"
+    rfc822Date =
+        formatTime defaultTimeLocale rfc822DateFormat
+      . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)
+
+feed :: MonadReader Blog m => String -> ArticlesList -> HtmlT m ()
+feed siteURL al@(ArticlesList {tagged, featured}) = do
+  prolog
+  rss_ [version, content, atom] $ do
+    channel_ $ do
+      title_ . toHtml =<< ArticlesList.title al
+      link_ . toHtml $ siteURL </> maybe "" id tagged
+      description_ . toHtml =<< ArticlesList.description al
+      mapM_ (articleItem siteURL) featured
+  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 {articlesFeatured, basePath, tag}) = do
+  limit <- take <$> (asks $skin.$previewArticlesCount)
+  let articlesList = ArticlesList {
+      tagged = tag, full = False, featured = limit articlesFeatured
+    }
+  renderTextT (feed siteURL articlesList)
+  >>= liftIO . TextIO.writeFile (basePath </> "rss" <.> "xml")
+
+generate :: ReaderT Blog IO ()
+generate = (asks $urls.$rss) >>= maybe (return ()) generateAll
+  where
+    generateAll siteURL = Collection.getAll >>= mapM_ (generateCollection siteURL)