From 107a9767ab8a06757eb177de95a328b1de3dcb26 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sun, 19 Apr 2020 21:30:41 +0200 Subject: [PATCH] Sort things out between Collection and ArticlesList (keep a link to the Collection and just add a flag saying whether the ArticlesList is a restricted version of or the whole Collection) and implement the generation of a link to the RSS feed --- src/ArticlesList.hs | 37 ++++++++++++++++++++++++------------- src/Blog.hs | 4 +++- src/Collection.hs | 16 +++++++++++----- src/DOM.hs | 27 ++++++++++++++++++--------- src/DOM/Card.hs | 10 ++++++---- src/HTML.hs | 35 ++++++++++++----------------------- src/JSON.hs | 2 ++ src/RSS.hs | 25 +++++++++++-------------- 8 files changed, 87 insertions(+), 69 deletions(-) diff --git a/src/ArticlesList.hs b/src/ArticlesList.hs index c3ed38a..d076ddb 100644 --- a/src/ArticlesList.hs +++ b/src/ArticlesList.hs @@ -4,38 +4,49 @@ module ArticlesList ( ArticlesList(..) , description + , getArticles , otherURL - , title + , rssLinkTexts ) where import Article (Article) -import Blog (Blog(..)) +import Blog (Blog(..), Skin(..)) import Blog.Wording (render) +import Collection (Collection(..)) import Control.Monad.Reader (MonadReader, asks) import Data.Text (Text, pack) import Files (absoluteLink) +import Pretty ((.$)) import System.FilePath.Posix (()) data ArticlesList = ArticlesList { - tagged :: Maybe String - , full :: Bool - , featured :: [Article] + full :: Bool + , collection :: Collection } -otherURL :: ArticlesList -> String -otherURL (ArticlesList {full, tagged}) = absoluteLink $ - (if full then id else ( "all.html")) $ maybe "" id tagged +getArticles :: MonadReader Blog m => ArticlesList -> m [Article] +getArticles (ArticlesList {full, collection = Collection {featured}}) = do + limit <- take <$> (asks $skin.$previewArticlesCount) + return $ if full then featured else limit featured -title :: MonadReader Blog m => ArticlesList -> m String -title (ArticlesList {tagged}) = do - asks $ (\name -> maybe name ((name ++ " - ") ++) tagged) . name +otherURL :: ArticlesList -> String +otherURL (ArticlesList {full, collection}) = absoluteLink $ + (if full then id else ( "all.html")) . maybe "" id $ tag collection description :: MonadReader Blog m => ArticlesList -> m Text -description (ArticlesList {full, tagged}) = - getDescription (full, tagged) <$> asks wording +description (ArticlesList {full, collection}) = + getDescription (full, tag collection) <$> asks wording where getDescription (True, Nothing) = render "allPage" [] getDescription (True, Just tag) = render "allTaggedPage" [("tag", pack tag)] getDescription (False, Nothing) = render "latestPage" [] getDescription (False, Just tag) = render "latestTaggedPage" [("tag", pack tag)] + +rssLinkTexts :: MonadReader Blog m => ArticlesList -> m (Text, Text) +rssLinkTexts (ArticlesList {collection}) = do + text <- asks $wording.$(render "rssLink" []) + title <- asks $wording.$(render "rssTitle" environment) + return (text, title) + where + environment = maybe [] (\v -> [("tag", pack v)]) $ tag collection diff --git a/src/Blog.hs b/src/Blog.hs index a2e6915..eb1545a 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -39,6 +39,7 @@ type Collection = Map String Article data Blog = Blog { articles :: Collection + , hasRSS :: Bool , name :: String , path :: Path , skin :: Skin @@ -92,9 +93,10 @@ build arguments = do wording <- Wording.build arguments root <- Files.absolute . Dir $ Arguments.sourceDir arguments withCurrentDirectory root $ do + let hasRSS = maybe False (\_-> True) $ rss urls path <- Path.build root arguments let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ Arguments.name arguments skin <- Skin.build name arguments (articles, tags) <- discover path - return $ Blog {articles, name, path, skin, tags, urls, wording} + return $ Blog {articles, hasRSS, name, path, skin, tags, urls, wording} diff --git a/src/Collection.hs b/src/Collection.hs index ae2c5c2..0a73798 100644 --- a/src/Collection.hs +++ b/src/Collection.hs @@ -1,10 +1,12 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} module Collection ( Collection(..) , getAll + , title ) where -import Article(Article(..)) +import Article(Article(metadata)) import Blog (Blog(..), Path(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT, asks) @@ -15,21 +17,21 @@ import Data.Ord (Down(..)) import qualified Data.Set as Set (member) import Pretty ((.$)) import System.Directory (createDirectoryIfMissing) -import System.FilePath.Posix (()) +import System.FilePath (()) data Collection = Collection { - articlesFeatured :: [Article] + featured :: [Article] , basePath :: FilePath , tag :: Maybe String } build :: MonadIO m => [Article] -> Maybe String -> ReaderT Blog m Collection -build articlesFeatured tag = do +build featured tag = do root <- asks $path.$root let basePath = maybe root (root ) tag liftIO $ createDirectoryIfMissing False basePath return $ Collection { - articlesFeatured = sortByDate articlesFeatured, basePath, tag + featured = sortByDate featured, basePath, tag } where sortByDate = sortOn (Down . (! "date") . metadata) @@ -45,3 +47,7 @@ getAll = do where getArticles tagged = Map.elems . Map.filterWithKey (\k _ -> Set.member k tagged) + +title :: MonadReader Blog m => Collection -> m String +title (Collection {tag}) = do + asks $ (\name -> maybe name ((name ++ " - ") ++) tag) . name diff --git a/src/DOM.hs b/src/DOM.hs index bd6673b..f52a40e 100644 --- a/src/DOM.hs +++ b/src/DOM.hs @@ -6,11 +6,13 @@ module DOM ( import Article (Article(..)) import qualified Article (preview) -import ArticlesList (ArticlesList(..), otherURL, description) +import ArticlesList ( + ArticlesList(..), description, getArticles, otherURL, rssLinkTexts + ) import Blog (Blog(..), Path(..), Skin(..), URL(..)) import qualified Blog (get) import Blog.Wording (render) -import Control.Monad.Reader (ReaderT) +import Control.Monad.Reader (ReaderT, asks) import qualified Data.Map as Map (keys) import Data.Text (pack, empty) import DOM.Card (HasCard) @@ -34,31 +36,38 @@ instance Page Article where content = article True instance Page ArticlesList where - content al@(ArticlesList {featured, full}) = do + content al@(ArticlesList {full}) = do preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount) h2_ . toHtml =<< description al - a_ [href_ . pack $ otherURL al] . toHtml =<< otherLink + ul_ $ do + asks hasRSS >>= rssLink + li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink div_ [class_ "articles"] ( - mapM_ (article False . preview) featured + mapM_ (article False . preview) =<< getArticles al ) where link = render (if full then "latestLink" else "allLink") [] - otherLink = Blog.get $wording.$(link) + otherLink = Blog.get $wording.$link.$toHtml + rssLink :: Bool -> HtmlGenerator () + rssLink True = do + (text, title) <- rssLinkTexts al + li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text + rssLink False = return () article :: Bool -> Article -> HtmlGenerator () article raw (Article {key, body, Article.title}) = do url <- absoluteLink . ( key <.> extension) <$> (Blog.get $path.$articlesPath) article_ [id_ $ pack key] (do header_ (do - a_ [href_ . pack $ url] . h1_ $ toHtml title + a_ [href_ $ pack url] . h1_ $ toHtml title ) pre_ . toHtml $ unlines body ) where extension = if raw then "md" else "html" tag :: String -> HtmlGenerator () -tag tagName = li_ ( - a_ [href_ . pack $ absoluteLink tagName, class_ "tag"] $ toHtml tagName +tag name = li_ ( + a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name ) defaultBanner :: HtmlGenerator () diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs index 41e9399..2860edd 100644 --- a/src/DOM/Card.hs +++ b/src/DOM/Card.hs @@ -9,9 +9,11 @@ module DOM.Card ( import qualified Article (Article(..)) import ArticlesList (ArticlesList(..)) -import qualified ArticlesList (description, title) +import qualified ArticlesList (description) import Blog (Blog(..), Skin(..)) import qualified Blog (get) +import Collection (Collection(..)) +import qualified Collection (title) import Control.Applicative ((<|>)) import Control.Monad.Reader (MonadReader) import qualified Data.Map as Map (lookup) @@ -64,15 +66,15 @@ instance HasCard Article.Article where getDescription = maybe (Blog.get $name.$("A new article on " <>)) return instance HasCard ArticlesList where - getCard al = do - cardTitle <- ArticlesList.title al + getCard al@(ArticlesList {collection}) = do + cardTitle <- Collection.title collection description <- ArticlesList.description al return $ Card { cardType = "website" , description , image = Nothing , DOM.Card.title = cardTitle - , urlPath = maybe "" ('/':) (tagged al) ++ file + , urlPath = maybe "" ('/':) (tag collection) ++ file } where file = '/' : (if full al then "all" else "index") ++ ".html" diff --git a/src/HTML.hs b/src/HTML.hs index c2d5fed..9818d13 100644 --- a/src/HTML.hs +++ b/src/HTML.hs @@ -6,7 +6,7 @@ module HTML ( import Article(Article(..)) import ArticlesList (ArticlesList(..)) -import Blog (Blog(..), Path(..), Skin(..)) +import Blog (Blog(..), Path(..)) import Collection (Collection(..)) import qualified Collection (getAll) import Control.Monad.IO.Class (MonadIO(..)) @@ -18,21 +18,13 @@ import Lucid (renderTextT) import Pretty ((.$)) import System.FilePath.Posix ((), (<.>)) -articlesLists :: Monad m => Collection -> ReaderT Blog m [(FilePath, ArticlesList)] -articlesLists (Collection {articlesFeatured, basePath, tag}) = do - limit <- take <$> (asks $skin.$previewArticlesCount) - return [ - (basePath "index" <.> "html", ArticlesList { - tagged = tag - , full = False - , featured = limit articlesFeatured - }) - , (basePath "all" <.> "html", ArticlesList { - tagged = tag - , full = True - , featured = articlesFeatured - }) - ] +articlesLists :: Collection -> [(FilePath, ArticlesList)] +articlesLists collection@(Collection {basePath}) = [ + (path full, ArticlesList {collection, full}) | full <- [False, True] + ] + where + file bool = if bool then "all" else "index" + path bool = basePath file bool <.> "html" generateArticles :: [Article] -> ReaderT Blog IO () generateArticles = mapM_ $ \article -> do @@ -41,13 +33,10 @@ generateArticles = mapM_ $ \article -> do >>= liftIO . TextIO.writeFile (baseDir key article <.> "html") generateCollection :: Collection -> ReaderT Blog IO () -generateCollection (Collection {articlesFeatured = []}) = return () -generateCollection aCollection = do - articlesLists aCollection - >>= (mapM_ $ \(filePath, articlesList) -> - (renderTextT $ page articlesList) - >>= liftIO . TextIO.writeFile filePath - ) +generateCollection (Collection {featured = []}) = return () +generateCollection collection = + flip mapM_ (articlesLists collection) $ \(filePath, articlesList) -> + (renderTextT $ page articlesList) >>= liftIO . TextIO.writeFile filePath generate :: ReaderT Blog IO () generate = do diff --git a/src/JSON.hs b/src/JSON.hs index 4b8b5bd..3562455 100644 --- a/src/JSON.hs +++ b/src/JSON.hs @@ -28,6 +28,7 @@ instance ToJSON ArticleExport where data BlogDB = BlogDB { articles :: Map String ArticleExport + , hasRSS :: Bool , path :: Path , skin :: Skin , tags :: Map String [String] @@ -51,6 +52,7 @@ exportBlog = do blog <- ask return . encode $ BlogDB { articles = mapWithKey (exportArticle blog) $ Blog.articles blog + , hasRSS = Blog.hasRSS blog , path = Blog.path blog , skin = Blog.skin blog , tags = Set.elems <$> Blog.tags blog diff --git a/src/RSS.hs b/src/RSS.hs index 4751fbd..52a9d49 100644 --- a/src/RSS.hs +++ b/src/RSS.hs @@ -6,10 +6,11 @@ module RSS ( ) where import Article (Article(..)) -import ArticlesList (ArticlesList(..)) -import qualified ArticlesList (description, title) -import Blog (Blog(..), Path(..), Skin(..), URL(..)) +import ArticlesList (ArticlesList(..), getArticles) +import qualified ArticlesList (description) +import Blog (Blog(..), Path(..), 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) @@ -68,27 +69,23 @@ articleItem siteURL (Article {key, metadata, title}) = . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int) feed :: MonadReader Blog m => String -> ArticlesList -> HtmlT m () -feed siteURL al@(ArticlesList {tagged, featured}) = do +feed siteURL al@(ArticlesList {collection}) = do prolog rss_ [version, content, atom] $ do channel_ $ do - title_ . toHtml =<< ArticlesList.title al - link_ . toHtml $ siteURL maybe "" id tagged + title_ . toHtml =<< Collection.title collection + link_ . toHtml $ siteURL maybe "" (++ "/") (tag collection) description_ . toHtml =<< ArticlesList.description al - mapM_ (articleItem siteURL) featured + 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 {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") +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