94 lines
3.1 KiB
Haskell
94 lines
3.1 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module RSS (
|
|
generate
|
|
) where
|
|
|
|
import Article (Article(..))
|
|
import ArticlesList (ArticlesList(..), getArticles)
|
|
import qualified ArticlesList (description)
|
|
import Blog (Blog(..), Path(..), 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 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 :: 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)
|