` element in the navigation `
` that lists all the tags of your blog.
diff --git a/hablo.cabal b/hablo.cabal
index 9e23312..01c480c 100644
--- a/hablo.cabal
+++ b/hablo.cabal
@@ -34,6 +34,7 @@ executable hablo
, ArticlesList
, Blog
, Blog.Path
+ , Blog.Template
, Blog.Skin
, Blog.URL
, Blog.Wording
diff --git a/share/defaultWording.conf b/share/defaultWording.conf
index 0fd4281..21b431b 100644
--- a/share/defaultWording.conf
+++ b/share/defaultWording.conf
@@ -1,11 +1,11 @@
allLink = See all
-allPage = All articles
-allTaggedPage = All articles tagged ${tag}
+allPage = All articles{? tagged ${tag}?}
commentsLink = Comment on the fediverse
commentsSection = Comments
dateFormat = en-US
latestLink = See only latest
-latestPage = Latest articles
-latestTaggedPage = Latest articles tagged ${tag}
+latestPage = Latest articles{? tagged ${tag}?}
metadata = {?by ${author} ?}on ${date}{? tagged ${tags}?}
+rssLink = Subscribe
+rssTitle = Follow all articles{? tagged ${tag}?}
tagsList = Tags
diff --git a/share/js/domRenderer.js b/share/js/domRenderer.js
index aa4a57b..8c688e7 100644
--- a/share/js/domRenderer.js
+++ b/share/js/domRenderer.js
@@ -66,29 +66,41 @@ function DomRenderer(modules) {
}
function pageTitle(tag, all) {
- if(tag != undefined) {
- var template = all ? 'allTaggedPage' : 'latestTaggedPage';
- return modules.template.render(template, {tag: tag});
- } else {
- return blog.wording[all ? 'allPage' : 'latestPage'];
- }
+ return modules.template.render(all ? 'allPage' : 'latestPage', {tag: tag});
}
function otherUrl(tag, all) {
- var path = [tag, all ? null : 'all.html'];
- return '/' + path.filter(modules.fun.defined).join('/');
+ return '/' + (tag || '') + (all ? '/' : '/all.html');
}
function articlesList(tag, all) {
return function(articlePreviews) {
return [
modules.dom.make('h2', {innerText: pageTitle(tag, all)}),
- modules.dom.make('a', {
- innerText: all ? blog.wording.latestLink : blog.wording.allLink,
- href: otherUrl(tag, all)
- }),
- modules.dom.make('div', {class: 'articles'}, articlePreviews.filter(modules.fun.defined))
+ modules.dom.make('ul', {}, articlesListLinks(tag, all)),
+ modules.dom.make('div', {class: 'articles'},
+ articlePreviews.filter(modules.fun.defined)
+ )
];
};
}
+
+ function articlesListLinks(tag, all) {
+ var links = [
+ modules.dom.make('a', {
+ innerText: all ? blog.wording.latestLink : blog.wording.allLink,
+ href: otherUrl(tag, all),
+ class: 'other'
+ })
+ ];
+ if(blog.hasRSS) {
+ links.unshift(modules.dom.make('a', {
+ innerText: blog.wording.rssLink,
+ href: 'rss.xml',
+ class: 'RSS',
+ title: modules.template.render('rssTitle', {tag: tag})
+ }));
+ }
+ return links.map(function(e) {return modules.dom.make('li', {}, [e]);});
+ }
}
diff --git a/src/ArticlesList.hs b/src/ArticlesList.hs
index 4f5f564..c111be0 100644
--- a/src/ArticlesList.hs
+++ b/src/ArticlesList.hs
@@ -4,42 +4,45 @@
module ArticlesList (
ArticlesList(..)
, description
- , otherUrl
- , title
+ , getArticles
+ , otherURL
+ , rssLinkTexts
) where
import Article (Article)
-import Blog (Blog(..))
-import Blog.Wording (render)
+import Blog (Blog(..), Renderer, Skin(..), template)
+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 :: Renderer m => ArticlesList -> m Text
+description (ArticlesList {full, collection}) =
+ template page . environment $ tag collection
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)]
-
-
-
-
+ page = if full then "allPage" else "latestPage"
+ environment = maybe [] $ \value -> [("tag", pack value)]
+
+rssLinkTexts :: Renderer m => ArticlesList -> m (Text, Text)
+rssLinkTexts (ArticlesList {collection}) = do
+ text <- template "rssLink" []
+ title <- template "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..188e983 100644
--- a/src/Blog.hs
+++ b/src/Blog.hs
@@ -1,13 +1,15 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
module Blog (
Blog(..)
, Path(..)
+ , Renderer
, Skin(..)
, URL(..)
, Wording
, build
- , get
+ , template
) where
import Arguments (Arguments)
@@ -16,6 +18,8 @@ import Article (Article)
import qualified Article (at, getKey)
import Blog.Path (Path(..))
import qualified Blog.Path as Path (build)
+import Blog.Template (Environment, Templates, render)
+import qualified Blog.Template as Template (build)
import Blog.Skin (Skin(..))
import qualified Blog.Skin as Skin (build)
import Blog.URL (URL(..))
@@ -23,11 +27,13 @@ import qualified Blog.URL as URL (build)
import Blog.Wording (Wording)
import qualified Blog.Wording as Wording (build)
import Control.Monad ((>=>), filterM, foldM, forM)
-import Control.Monad.Reader (MonadReader, ask)
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Reader (MonadReader, asks)
import Data.Map (Map, insert, lookup)
import qualified Data.Map as Map (empty, fromList)
import Data.Set (Set)
import qualified Data.Set as Set (empty, null, singleton, union)
+import Data.Text (Text)
import Files (File(..), absolute)
import qualified Files (find)
import Prelude hiding (lookup)
@@ -39,16 +45,20 @@ type Collection = Map String Article
data Blog = Blog {
articles :: Collection
+ , hasRSS :: Bool
, name :: String
, path :: Path
, skin :: Skin
, tags :: Map String (Set String)
+ , templates :: Templates
, urls :: URL
, wording :: Wording
}
-get :: MonadReader Blog m => (Blog -> a) -> m a
-get = (<$> ask)
+type Renderer m = (MonadIO m, MonadReader Blog m)
+
+template :: Renderer m => String -> Environment -> m Text
+template key environment = asks templates >>= render key environment
keepOrWarn :: Map String Article -> Either ParseError (String, Article) -> IO (Map String Article)
keepOrWarn accumulator (Left parseErrors) =
@@ -89,7 +99,9 @@ discover path = do
build :: Arguments -> IO Blog
build arguments = do
urls <- URL.build arguments
+ let hasRSS = maybe False (\_-> True) $ rss urls
wording <- Wording.build arguments
+ templates <- Template.build wording
root <- Files.absolute . Dir $ Arguments.sourceDir arguments
withCurrentDirectory root $ do
path <- Path.build root arguments
@@ -97,4 +109,6 @@ build arguments = do
$ 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, templates, urls, wording
+ }
diff --git a/src/Blog/Template.hs b/src/Blog/Template.hs
new file mode 100644
index 0000000..e9ee71a
--- /dev/null
+++ b/src/Blog/Template.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Blog.Template (
+ Environment
+ , Templates(..)
+ , build
+ , render
+ ) where
+
+import Blog.Wording (Wording(..), variables)
+import Control.Monad (foldM)
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.List (intercalate)
+import Data.Map (Map, (!))
+import qualified Data.Map as Map (empty, insert, keys)
+import Data.Text (Text, breakOn)
+import qualified Data.Text as Text (concat, drop, null, unpack)
+import Data.Text.Lazy (toStrict)
+import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
+import System.Exit (die)
+
+data TemplateChunk = Top Template | Sub Template
+newtype HabloTemplate = HabloTemplate [TemplateChunk]
+newtype Templates = Templates (Map String HabloTemplate)
+type Environment = [(Text, Text)]
+
+render :: MonadIO m => String -> Environment -> Templates -> m Text
+render key environment (Templates templates) =
+ (Text.concat . fmap toStrict) <$> mapM renderChunk templateChunks
+ where
+ HabloTemplate templateChunks = templates ! key
+ renderer template = renderA template (flip lookup environment)
+ renderChunk (Top template) =
+ let err = "Could not template " ++ Text.unpack (showTemplate template) in
+ maybe (liftIO $ die err) return $ renderer template
+ renderChunk (Sub template) = return . maybe "" id $ renderer template
+
+makeTemplate :: String -> Text -> IO Template
+makeTemplate key templateText =
+ let testEnvironment = flip lookup [(s, "") | s <- availableVariables] in
+ case templateSafe templateText of
+ Left (row, col) -> die $ syntaxError (show row) (show col)
+ Right template ->
+ maybe (die badTemplate) (return . const template) (renderA template testEnvironment)
+ where
+ availableVariables = variables ! key
+ variablesMessage =
+ " (available variables: " ++ intercalate ", " (Text.unpack <$> availableVariables) ++ ")"
+ syntaxError row col =
+ "Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col
+ badTemplate = "Invalid template for variable " ++ key ++ variablesMessage
+
+makeHabloTemplate :: String -> Map String Text -> IO HabloTemplate
+makeHabloTemplate key wording = HabloTemplate <$> toHablo True (wording ! key)
+ where
+ toHablo _ "" = return []
+ toHablo atTop template = do
+ let (start, rest) = (Text.drop 2) <$> breakOn (delimiter atTop) template
+ push atTop start <*> toHablo (not atTop) rest
+ delimiter atTop = if atTop then "{?" else "?}"
+ push atTop t
+ | Text.null t = return id
+ | otherwise = (:) . (if atTop then Top else Sub) <$> makeTemplate key t
+
+build :: Wording -> IO Templates
+build (Wording wordingMap) =
+ Templates <$> foldM templateWording Map.empty (Map.keys variables)
+ where
+ templateWording templated key =
+ flip (Map.insert key) templated <$> makeHabloTemplate key wordingMap
diff --git a/src/Blog/Wording.hs b/src/Blog/Wording.hs
index e20e2d9..e393db8 100644
--- a/src/Blog/Wording.hs
+++ b/src/Blog/Wording.hs
@@ -1,22 +1,17 @@
-{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Blog.Wording (
Wording(..)
, build
- , render
+ , variables
) where
import Arguments (Arguments(..))
import Control.Monad (foldM)
import Data.Aeson (ToJSON(..))
-import Data.List (intercalate)
-import Data.Map (Map, (!))
-import qualified Data.Map as Map (empty, fromList, insert, keys, map, union)
+import Data.Map (Map)
+import qualified Data.Map as Map (empty, fromList, keys, map, union)
import Data.Text (Text)
-import qualified Data.Text as Text (pack, unpack)
-import Data.Text.Lazy (toStrict)
-import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
-import qualified Data.Text.Template as Template (render)
+import qualified Data.Text as Text (pack)
import Paths_hablo (getDataFileName)
import Text.ParserCombinators.Parsec (
Parser
@@ -25,31 +20,26 @@ import Text.ParserCombinators.Parsec (
)
import System.Exit (die)
-newtype Wording = Wording (Map String Template)
+newtype Wording = Wording (Map String Text)
variables :: Map String [Text]
variables = Map.fromList [
("allLink", [])
- , ("allPage", [])
- , ("allTaggedPage", ["tag"])
+ , ("allPage", ["tag"])
, ("commentsLink", [])
, ("commentsSection", [])
, ("dateFormat", [])
, ("latestLink", [])
- , ("latestPage", [])
- , ("latestTaggedPage", ["tag"])
+ , ("latestPage", ["tag"])
, ("metadata", ["author", "date", "tags"])
+ , ("rssLink", [])
+ , ("rssTitle", ["tag"])
, ("tagsList", [])
]
-
instance ToJSON Wording where
- toJSON (Wording m) = toJSON (showTemplate <$> m)
- toEncoding (Wording m) = toEncoding (showTemplate <$> m)
-
-render :: String -> [(Text, Text)] -> Wording -> Text
-render key env (Wording wMap) =
- toStrict $ Template.render (wMap ! key) (Map.fromList env !)
+ toJSON (Wording m) = toJSON m
+ toEncoding (Wording m) = toEncoding m
addWording :: Map String Text -> FilePath -> IO (Map String Text)
addWording currentWording wordingFile = do
@@ -65,30 +55,12 @@ wordingP = Map.map Text.pack . Map.fromList <$>
restOfLine = many $ noneOf "\r\n"
eol = try (string "\r\n") <|> string "\r" <|> string "\n"
skip = optional (char '#' *> restOfLine) *> eol
- line = (,) <$> (choice (try . string <$> Map.keys variables) <* equal) <*> restOfLine
+ varEqual = choice (try . string <$> Map.keys variables) <* equal
+ line = (,) <$> varEqual <*> restOfLine
equal = many (char ' ') *> char '=' *> many (char ' ')
-makeTemplate :: String -> Map String Text -> IO Template
-makeTemplate key wording =
- let templateText = wording ! key in
- let testEnvironment = flip lookup [(s, "") | s <- availableVariables] in
- case templateSafe templateText of
- Left (row, col) -> die $ syntaxError (show row) (show col)
- Right template ->
- maybe (die badTemplate) (return . const template) (renderA template testEnvironment)
- where
- availableVariables = variables ! key
- variablesMessage =
- " (available variables: " ++ intercalate ", " (Text.unpack <$> availableVariables) ++ ")"
- syntaxError row col =
- "Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col
- badTemplate = "Invalid template for variable " ++ key ++ variablesMessage
-
build :: Arguments -> IO Wording
build arguments = do
defaultWording <- getDataFileName "defaultWording.conf"
let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
- wordindMap <- foldM addWording Map.empty wordingFiles
- Wording <$> foldM (
- \templated key -> flip (Map.insert key) templated <$> makeTemplate key wordindMap
- ) Map.empty (Map.keys variables)
+ Wording <$> foldM addWording Map.empty wordingFiles
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 00c976c..66f83ac 100644
--- a/src/DOM.hs
+++ b/src/DOM.hs
@@ -6,11 +6,11 @@ module DOM (
import Article (Article(..))
import qualified Article (preview)
-import ArticlesList (ArticlesList(..), otherUrl, description)
-import Blog (Blog(..), Path(..), Skin(..), URL(..))
-import qualified Blog (get)
-import Blog.Wording (render)
-import Control.Monad.Reader (ReaderT)
+import ArticlesList (
+ ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
+ )
+import Blog (Blog(..), Path(..), Skin(..), URL(..), template)
+import Control.Monad.Reader (ReaderT, asks)
import qualified Data.Map as Map (keys)
import Data.Text (pack, empty)
import DOM.Card (HasCard)
@@ -34,38 +34,45 @@ instance Page Article where
content = article True
instance Page ArticlesList where
- content al@(ArticlesList {featured, full}) = do
- preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount)
+ content al@(ArticlesList {full}) = do
+ preview <- Article.preview <$> (asks $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 =
+ toHtml <$> template (if full then "latestLink" else "allLink") []
+ 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)
+ url <- absoluteLink . (> key <.> extension) <$> (asks $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 ()
defaultBanner = do
div_ [id_ "header"] (
a_ [href_ "/"] (
- h1_ . toHtml =<< Blog.get name
+ h1_ . toHtml =<< asks name
)
)
@@ -80,19 +87,19 @@ page aPage =
doctypehtml_ (do
head_ (do
meta_ [charset_ "utf-8"]
- title_ . toHtml =<< Blog.get name
+ title_ . toHtml =<< asks name
script_ [src_ "/js/unit.js"] empty
script_ [src_ "/js/remarkable.min.js"] empty
script_ [src_ "/js/hablo.js"] empty
- optional faviconLink =<< (Blog.get $skin.$favicon)
- optional (Card.make aPage) =<< (Blog.get $urls.$cards)
- (Blog.get $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
+ optional faviconLink =<< (asks $skin.$favicon)
+ optional (Card.make aPage) =<< (asks $urls.$cards)
+ optional toHtmlRaw =<< (asks $skin.$head)
)
body_ (do
- maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
+ maybe defaultBanner toHtmlRaw =<< (asks $skin.$banner)
div_ [id_ "navigator"] (do
- h2_ =<< (Blog.get $wording.$(render "tagsList" []).$toHtml)
- ul_ . mapM_ tag . Map.keys =<< Blog.get tags
+ h2_ . toHtml =<< template "tagsList" []
+ ul_ . mapM_ tag . Map.keys =<< asks tags
)
div_ [id_ "contents"] $ content aPage
)
diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs
index 41e9399..55334cc 100644
--- a/src/DOM/Card.hs
+++ b/src/DOM/Card.hs
@@ -9,11 +9,12 @@ module DOM.Card (
import qualified Article (Article(..))
import ArticlesList (ArticlesList(..))
-import qualified ArticlesList (description, title)
-import Blog (Blog(..), Skin(..))
-import qualified Blog (get)
+import qualified ArticlesList (description)
+import Blog (Blog(..), Renderer, Skin(..))
+import Collection (Collection(..))
+import qualified Collection (title)
import Control.Applicative ((<|>))
-import Control.Monad.Reader (MonadReader)
+import Control.Monad.Reader (asks)
import qualified Data.Map as Map (lookup)
import Data.Text (Text, pack)
import Lucid (HtmlT, content_, meta_)
@@ -29,7 +30,7 @@ data Card = Card {
}
class HasCard a where
- getCard :: MonadReader Blog m => a -> m Card
+ getCard :: Renderer m => a -> m Card
og :: Applicative m => Text -> Text -> HtmlT m ()
og attribute value =
@@ -38,15 +39,15 @@ og attribute value =
, content_ value
]
-make :: (HasCard a, MonadReader Blog m) => a -> String -> HtmlT m ()
+make :: (HasCard a, Renderer m) => a -> String -> HtmlT m ()
make element siteURL = do
Card {cardType, description, image, title, urlPath} <- getCard element
og "url" . pack $ siteURL ++ urlPath
og "type" cardType
og "title" $ pack title
og "description" description
- maybeImage =<< ((image <|>) <$> (Blog.get $skin.$cardImage))
- og "site_name" =<< (Blog.get $name.$pack)
+ maybeImage =<< ((image <|>) <$> (asks $skin.$cardImage))
+ og "site_name" =<< (asks $name.$pack)
where
maybeImage = maybe (return ()) (og "image" . pack . (siteURL++))
@@ -61,18 +62,18 @@ instance HasCard Article.Article where
, urlPath = "/articles/" ++ title ++ ".html"
}
where
- getDescription = maybe (Blog.get $name.$("A new article on " <>)) return
+ getDescription = maybe (asks $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/JS.hs b/src/JS.hs
index 22f6372..5cd1ad1 100644
--- a/src/JS.hs
+++ b/src/JS.hs
@@ -4,9 +4,8 @@ module JS (
) where
import Blog (Blog(..), Path(..))
-import qualified Blog (get)
import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Reader (ReaderT)
+import Control.Monad.Reader (ReaderT, asks)
import Data.ByteString.Lazy (ByteString, concat, readFile, writeFile)
import Data.ByteString.Lazy.Char8 (pack)
import qualified Files (find)
@@ -28,9 +27,9 @@ var (varName, content) = concat ["var ", pack varName, " = ", content, ";\n"]
generate :: ReaderT Blog IO ()
generate = do
- destinationDir <- (> "js") <$> (Blog.get $path.$root)
+ destinationDir <- (> "js") <$> (asks $path.$root)
blogJSON <- exportBlog
- remarkablePath <- Blog.get $path.$remarkableConfig
+ remarkablePath <- asks $path.$remarkableConfig
liftIO $ do
remarkableJSON <- maybe (return "{html: true}") readFile remarkablePath
let jsVars = var <$> [("blog", blogJSON), ("remarkableConfig", remarkableJSON)]
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..73f8b79 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(..), 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)
@@ -67,28 +68,24 @@ articleItem siteURL (Article {key, metadata, title}) =
formatTime defaultTimeLocale rfc822DateFormat
. posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)
-feed :: MonadReader Blog m => String -> ArticlesList -> HtmlT m ()
-feed siteURL al@(ArticlesList {tagged, featured}) = do
+feed :: Renderer m => String -> ArticlesList -> HtmlT m ()
+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