{-# 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 :: HtmlT m ()
prolog = String -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw (String
"<?xml  version=\"1.0\" encoding=\"UTF-8\" ?>" :: String)

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

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

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

rss_ :: Term arg result => arg -> result
rss_ :: arg -> result
rss_ = Text -> arg -> result
forall arg result. Term arg result => Text -> arg -> result
term Text
"rss"

channel_ :: Term arg result => arg -> result
channel_ :: arg -> result
channel_ = Text -> arg -> result
forall arg result. Term arg result => Text -> arg -> result
term Text
"channel"

title_ :: Term arg result => arg -> result
title_ :: arg -> result
title_ = Text -> arg -> result
forall arg result. Term arg result => Text -> arg -> result
term Text
"title"

link_ :: Term arg result => arg -> result
link_ :: arg -> result
link_ = Text -> arg -> result
forall arg result. Term arg result => Text -> arg -> result
term Text
"link"

description_ :: Term arg result => arg -> result
description_ :: arg -> result
description_ = Text -> arg -> result
forall arg result. Term arg result => Text -> arg -> result
term Text
"description"

item_ :: Term arg result => arg -> result
item_ :: arg -> result
item_ = Text -> arg -> result
forall arg result. Term arg result => Text -> arg -> result
term Text
"item"

pubDate_ :: Term arg result => arg -> result
pubDate_ :: arg -> result
pubDate_ = Text -> arg -> result
forall arg result. Term arg result => Text -> arg -> result
term Text
"pubDate"

articleItem :: MonadReader Blog m => String -> Article -> HtmlT m ()
articleItem :: String -> Article -> HtmlT m ()
articleItem String
siteURL (Article (Markdown {String
path :: Markdown -> String
path :: String
path, Metadata
metadata :: Markdown -> Metadata
metadata :: Metadata
metadata, String
title :: Markdown -> String
title :: String
title})) =
  HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
item_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
    HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
title_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ String -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml String
title
    HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
link_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ String -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (String
siteURL String -> String -> String
</> String
path String -> String -> String
<.> String
"html")
    HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
pubDate_ (HtmlT m () -> HtmlT m ())
-> (String -> HtmlT m ()) -> String -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (String -> HtmlT m ())
-> (String -> String) -> String -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
rfc822Date (String -> HtmlT m ()) -> String -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Metadata
metadata Metadata -> String -> String
forall k a. Ord k => Map k a -> k -> a
! String
"date"
  where
    rfc822Date :: String -> String
rfc822Date =
        TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
rfc822DateFormat
      (UTCTime -> String) -> (String -> UTCTime) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime)
-> (String -> POSIXTime) -> String -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> POSIXTime) -> (String -> Int) -> String -> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Int
forall a. Read a => String -> a
read :: String -> Int)

feed :: Renderer m => String -> ArticlesList -> HtmlT m ()
feed :: String -> ArticlesList -> HtmlT m ()
feed String
siteURL al :: ArticlesList
al@(ArticlesList {Collection
collection :: ArticlesList -> Collection
collection :: Collection
collection}) = do
  HtmlT m ()
forall (m :: * -> *). Monad m => HtmlT m ()
prolog
  [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
rss_ [Attribute
version, Attribute
content, Attribute
atom] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
    HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
channel_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
      HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
title_ (HtmlT m () -> HtmlT m ())
-> (String -> HtmlT m ()) -> String -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (String -> HtmlT m ()) -> HtmlT m String -> HtmlT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Collection -> HtmlT m String
forall (m :: * -> *). MonadReader Blog m => Collection -> m String
Collection.title Collection
collection
      HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
link_ (HtmlT m () -> HtmlT m ())
-> (String -> HtmlT m ()) -> String -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (String -> HtmlT m ()) -> String -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ String
siteURL String -> String -> String
</> String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/") (Collection -> Maybe String
tag Collection
collection)
      HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
description_ (HtmlT m () -> HtmlT m ())
-> (Text -> HtmlT m ()) -> Text -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (Text -> HtmlT m ()) -> HtmlT m Text -> HtmlT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArticlesList -> HtmlT m Text
forall (m :: * -> *). Renderer m => ArticlesList -> m Text
ArticlesList.description ArticlesList
al
      (Article -> HtmlT m ()) -> [Article] -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Article -> HtmlT m ()
forall (m :: * -> *).
MonadReader Blog m =>
String -> Article -> HtmlT m ()
articleItem String
siteURL) ([Article] -> HtmlT m ()) -> HtmlT m [Article] -> HtmlT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArticlesList -> HtmlT m [Article]
forall (m :: * -> *).
MonadReader Blog m =>
ArticlesList -> m [Article]
getArticles ArticlesList
al
  where
    version :: Attribute
version = Text -> Attribute
version_ Text
"2.0"
    content :: Attribute
content = Text -> Attribute
xmlns_content_ Text
"http://purl.org/rss/1.0/modules/content/"
    atom :: Attribute
atom = Text -> Attribute
xmlns_atom_ Text
"http://www.w3.org/2005/Atom"

generateCollection :: String -> Collection -> ReaderT Blog IO ()
generateCollection :: String -> Collection -> ReaderT Blog IO ()
generateCollection String
siteURL Collection
collection =
  HtmlT (ReaderT Blog IO) () -> ReaderT Blog IO Text
forall (m :: * -> *) a. Monad m => HtmlT m a -> m Text
renderTextT (String -> ArticlesList -> HtmlT (ReaderT Blog IO) ()
forall (m :: * -> *).
Renderer m =>
String -> ArticlesList -> HtmlT m ()
feed String
siteURL (ArticlesList -> HtmlT (ReaderT Blog IO) ())
-> ArticlesList -> HtmlT (ReaderT Blog IO) ()
forall a b. (a -> b) -> a -> b
$ ArticlesList :: Bool -> Collection -> ArticlesList
ArticlesList {full :: Bool
full = Bool
False, Collection
collection :: Collection
collection :: Collection
collection})
  ReaderT Blog IO Text
-> (Text -> ReaderT Blog IO ()) -> ReaderT Blog IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ReaderT Blog IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Blog IO ())
-> (Text -> IO ()) -> Text -> ReaderT Blog IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> IO ()
TextIO.writeFile (Collection -> String
basePath Collection
collection String -> String -> String
</> String
"rss" String -> String -> String
<.> String
"xml")

generate :: ReaderT Blog IO ()
generate :: ReaderT Blog IO ()
generate = ((Blog -> Maybe String) -> ReaderT Blog IO (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Blog -> Maybe String) -> ReaderT Blog IO (Maybe String))
-> (Blog -> Maybe String) -> ReaderT Blog IO (Maybe String)
forall a b. (a -> b) -> a -> b
$Blog -> URL
urls(Blog -> URL) -> (URL -> Maybe String) -> Blog -> Maybe String
forall a b c. (a -> b) -> (b -> c) -> a -> c
.$URL -> Maybe String
rss) ReaderT Blog IO (Maybe String)
-> (Maybe String -> ReaderT Blog IO ()) -> ReaderT Blog IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT Blog IO ()
-> (String -> ReaderT Blog IO ())
-> Maybe String
-> ReaderT Blog IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ReaderT Blog IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) String -> ReaderT Blog IO ()
generateAll
  where
    generateAll :: String -> ReaderT Blog IO ()
generateAll String
siteURL = ReaderT Blog IO [Collection]
Collection.getAll ReaderT Blog IO [Collection]
-> ([Collection] -> ReaderT Blog IO ()) -> ReaderT Blog IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Collection -> ReaderT Blog IO ())
-> [Collection] -> ReaderT Blog IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Collection -> ReaderT Blog IO ()
generateCollection String
siteURL)