96 lines
3.1 KiB
Haskell
96 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, 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)
|