diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,27 @@
# Revision history for hablo
+## 1.1.0.1 -- 2021-01-20
+
+* Ensure compilation on Nix as far as 18.09
+* Fix missing metadata when landing on articles
+
+## 1.1.0.0 -- 2020-12-13
+
+* Implement static pages
+* Implement RSS feeds
+* Use SJW to pack JS into a single script and simplify deployment
+
+## 1.0.3.0 -- 2019-12-21
+
+* Fix OpenGraph cards displayed for links to hablo-generated pages posted on the Fediverse (should work elsewhere too but I don't care and have never tested)
+* This fix alas requires to «anchor» the generated website at a given location by means of the new `--site-url` option. OpenGraph cards are just completely disabled if you prefer your website to remain portable.
+
+## 1.0.2.0 -- 2019-08-27
+
+* Format for [conditional blocks](/Tissevert/hablo/wiki/Template-variables#metadata) changed to allow an internal simplification. This is transparent if you're creating a new blog or using the default wording but be sure to edit your wording if you're using a custom one :
+
+`${? … ?}` becomes `{? … ?}`
+
## 1.0.1.0 -- 2019-04-28
* Print warnings about malformed Markdown articles instead of ignoring them silently
diff --git a/hablo.cabal b/hablo.cabal
--- a/hablo.cabal
+++ b/hablo.cabal
@@ -3,16 +3,16 @@
-- For further documentation, see http://haskell.org/cabal/users-guide/
name: hablo
-version: 1.0.1.0
+version: 1.1.0.1
synopsis: A minimalist static blog generator
description:
Hablo is a fediverse-oriented static blog generator for articles written
in Markdown. It tries to generate as little HTML as needed and uses
Javascript to implement dynamic features in the browser.
- Those features include the handling of comments and a cached navigation
- to minimize the queries to the server. Hablo also generate cards for all
- pages, including articles for prettier shares on social-networks.
+ Those features include the handling of comments and a cached navigation to
+ minimize the number of queries to the server. Hablo also generates RSS feeds
+ and Open Graph cards for prettier shares on social networks.
homepage: https://git.marvid.fr/Tissevert/hablo
-- bug-reports:
license: BSD3
@@ -27,37 +27,86 @@
data-files: js/*.js
defaultWording.conf
-executable hablo
- main-is: Main.hs
- other-modules: Arguments
+library
+ exposed-modules: Arguments
, Article
, ArticlesList
, Blog
, Blog.Path
+ , Blog.Template
, Blog.Skin
+ , Blog.URL
, Blog.Wording
- , Dom
+ , Collection
+ , DOM
+ , DOM.Card
, Files
, HTML
, JS
, JSON
+ , Markdown
+ , Page
, Paths_hablo
, Pretty
+ , RSS
-- other-extensions:
- build-depends: aeson >= 1.4.2 && < 1.5
- , base >= 4.12.0 && < 4.13
- , bytestring >= 0.10.8 && < 0.11
- , containers >= 0.6.0 && < 0.7
- , directory >= 1.3.3 && < 1.4
+ build-depends: aeson >= 1.2.0 && < 1.6
+ , base >= 4.9.1 && < 4.15
+ , bytestring >= 0.10.8 && < 0.12
+ , containers >= 0.5.11 && < 0.7
+ , directory >= 1.3.1 && < 1.4
, filepath >= 1.4.2 && < 1.5
- , lucid >= 2.9.11 && < 2.10
+ , lucid >= 2.8.0 && < 2.10
, mtl >= 2.2.2 && < 2.3
- , optparse-applicative >= 0.14.3 && < 0.15
+ , optparse-applicative >= 0.14.0 && < 0.17
, parsec >= 3.1.13 && < 3.2
, template >= 0.2.0 && < 0.3
, text >= 1.2.3 && < 1.3
- , time >= 1.8.0 && < 1.9
+ , time >= 1.8.0 && < 1.12
+ , SJW >= 0.1.2 && < 0.2
, unix >= 2.7.2 && < 2.8
- ghc-options: -Wall -dynamic
+ ghc-options: -Wall
hs-source-dirs: src
+ default-language: Haskell2010
+
+executable hablo
+ main-is: src/Main.hs
+ other-modules: Paths_hablo
+ -- other-extensions:
+ build-depends: base >= 4.9.1 && < 4.15
+ , hablo
+ , mtl >= 2.2.2 && < 2.3
+ ghc-options: -Wall
+ default-language: Haskell2010
+
+test-suite tests
+ type: detailed-0.9
+ test-module: Tests
+ other-modules: Mock.Arguments
+ , Mock.Article
+ , Mock.ArticlesList
+ , Mock.Blog
+ , Mock.Blog.Path
+ , Mock.Blog.Skin
+ , Mock.Blog.Template
+ , Mock.Blog.URL
+ , Mock.Blog.Wording
+ , Mock.Collection
+ , Mock.Markdown
+ , Structure
+ , Utils
+ , XML.Card
+ , XML.Card.Component
+ , XML.Card.Output
+ build-depends: base
+ , Cabal
+ , containers
+ , directory
+ , filepath
+ , hablo
+ , lucid
+ , mtl
+ , text
+ hs-source-dirs: test
+ ghc-options: -Wall
default-language: Haskell2010
diff --git a/share/defaultWording.conf b/share/defaultWording.conf
--- a/share/defaultWording.conf
+++ b/share/defaultWording.conf
@@ -1,11 +1,14 @@
allLink = See all
-allPage = All articles
-allTaggedPage = All articles tagged ${tag}
+allPage = All articles{? tagged ${tag}?}
+articleDescription = A new article on ${name}
commentsLink = Comment on the fediverse
commentsSection = Comments
dateFormat = en-US
latestLink = See only latest
-latestPage = Latest articles
-latestTaggedPage = Latest articles tagged ${tag}
-metadata = ${?by ${author} ?}on ${date}${? tagged ${tags}?}
+latestPage = Latest articles{? tagged ${tag}?}
+metadata = {?by ${author} ?}on ${date}{? tagged ${tags}?}
+pageDescription = Read on ${name}
+pagesList = Pages
+rssLink = Subscribe
+rssTitle = Follow all articles{? tagged ${tag}?}
tagsList = Tags
diff --git a/share/js/DomRenderer.js b/share/js/DomRenderer.js
new file mode 100644
--- /dev/null
+++ b/share/js/DomRenderer.js
@@ -0,0 +1,143 @@
+import blog from Hablo.Config;
+import Metadata;
+import Remarkable;
+import Template;
+import * as Dom from UnitJS.Dom;
+import {defined} from UnitJS.Fun;
+
+return {
+ articlesList: articlesList,
+ getResource: getResource,
+ render: render,
+ replaceMarkdown: replaceMarkdown
+};
+
+function getResource(url) {
+ var i = url.lastIndexOf('/');
+ var path = url.slice(1, i);
+ if(path == blog.path.articlesPath) {
+ return {type: 'article', key: url.slice(i+1).replace(/\.html/, '')};
+ } else if(path == blog.path.pagesPath) {
+ return {type: 'page', key: url.slice(i+1).replace(/\.html/, '')};
+ } else if(path == '' || blog.tags[path] != undefined) {
+ var tag = path.length > 0 ? path : undefined;
+ return {type: 'list', tag: tag, all: url.slice(i+1) == 'all.html'};
+ } else {
+ return {type: 'unknown'};
+ }
+}
+
+function resourceUrl(resource, limit) {
+ var directory = blog.path[resource.type + 'sPath'];
+ var extension = limit != undefined ? '.html' : '.md';
+ return ["", directory, resource.key + extension].join('/');
+}
+
+function replaceMarkdown() {
+ var div = document.getElementById('contents');
+ if(div.children[0] && div.children[0].tagName.toLowerCase() == 'article') {
+ var resourceType = getResource(window.location.pathname).type;
+ convertContent(resourceType, div.children[0], true);
+ } else {
+ var articles = div.getElementsByClassName('articles')[0];
+ if(articles != undefined) {
+ for(var i = 0; i < articles.children.length; i++) {
+ convertContent('article', articles.children[i]);
+ }
+ } else {
+ console.log('No articles found for this page');
+ }
+ }
+}
+
+function convertContent(resourceType, article, comments) {
+ var header = article.getElementsByTagName('header')[0];
+ if(resourceType == 'article') {
+ header.appendChild(Metadata.get(article.id));
+ }
+ var text = article.getElementsByTagName('pre')[0];
+ if(text != undefined) {
+ article.replaceChild(getDiv(text.innerText), text);
+ if(resourceType == 'article' && comments) {
+ Metadata.getComments(article.id)
+ .forEach(article.appendChild.bind(article));
+ }
+ } else {
+ console.log('No content found for this article');
+ }
+}
+
+function getDiv(markdown) {
+ var d= Dom.make('div', {
+ innerHTML: Remarkable.md.render(markdown)
+ });
+ var scripts = d.getElementsByTagName('script');
+ for(var i = 0; i < scripts.length; i++) {
+ var run = Dom.make('script',
+ {type: 'text/javascript', src: scripts[i].src, textContent: scripts[i].textContent}
+ );
+ scripts[i].parentNode.replaceChild(run, scripts[i]);
+ }
+ return d;
+}
+
+function commentsSection(resource, limit) {
+ if(resource.type != 'article' || limit != undefined) {
+ return [];
+ } else {
+ return Metadata.getComments(resource.key);
+ }
+}
+
+function render(resource, markdown, limit) {
+ var url = resourceUrl(resource, limit);
+ var content = blog[resource.type + 's'][resource.key];
+ var lines = markdown.split(/\n/).slice(content.bodyOffset);
+ var div = getDiv(lines.slice(0, limit).join('\n'));
+ return Dom.make('article', {}, [
+ Dom.make('header', {}, [
+ Dom.make('h1', {}, [
+ Dom.make('a', {href: url, innerText: content.title})
+ ])].concat(resource.type == 'article' ? Metadata.get(resource.key) : [])
+ ),
+ div
+ ].concat(commentsSection(resource, limit)));
+}
+
+function pageTitle(resource) {
+ return Template.render(resource.all ? 'allPage' : 'latestPage', {tag: resource.tag});
+}
+
+function otherUrl(resource) {
+ var path = [resource.tag, resource.all ? '' : 'all.html'];
+ return '/' + path.filter(defined).join('/');
+}
+
+function articlesList(resource) {
+ return function(articlePreviews) {
+ return [
+ Dom.make('h2', {innerText: pageTitle(resource)}),
+ Dom.make('ul', {}, articlesListLinks(resource)),
+ Dom.make('div', {class: 'articles'}, articlePreviews.filter(defined))
+ ];
+ };
+}
+
+function articlesListLinks(resource) {
+ var links = [
+ Dom.make('a', {
+ innerText: resource.all ? blog.wording.latestLink : blog.wording.allLink,
+ href: otherUrl(resource),
+ class: 'other'
+ })
+ ];
+ if(blog.hasRSS) {
+ links.unshift(Dom.make('a', {
+ innerText: blog.wording.rssLink,
+ href: 'rss.xml',
+ class: 'RSS',
+ title: Template.render('rssTitle', {tag: resource.tag})
+ }));
+ }
+ return links.map(function(e) {return Dom.make('li', {}, [e]);});
+}
diff --git a/share/js/Main.js b/share/js/Main.js
new file mode 100644
--- /dev/null
+++ b/share/js/Main.js
@@ -0,0 +1,5 @@
+import replaceMarkdown from DomRenderer;
+import hijackLinks from Navigation;
+
+replaceMarkdown();
+hijackLinks();
diff --git a/share/js/Metadata.js b/share/js/Metadata.js
new file mode 100644
--- /dev/null
+++ b/share/js/Metadata.js
@@ -0,0 +1,159 @@
+import blog from Hablo.Config;
+import Template;
+import * as Async from UnitJS.Async;
+import * as Cache from UnitJS.Cache;
+import * as Dom from UnitJS.Dom;
+
+var comments = Cache.make(function(threadId) {
+ return Async.bind(
+ Async.parallel(
+ getJSON(url(threadId)),
+ getJSON(url(threadId) + '/context'),
+ ),
+ Async.map(function(t) {
+ return [renderLink(t[0]), renderAnswers(t[1])];
+ })
+ );
+});
+return {
+ get: get,
+ getComments: getComments
+};
+
+function url(threadId) {
+ return blog.urls.comments + '/api/v1/statuses/' + threadId;
+}
+
+function getJSON(url) {
+ return Async.bind(
+ Async.http({method: 'GET', url: url}),
+ function(queryResult) {
+ if(queryResult.status == 200) {
+ try {
+ return Async.wrap(JSON.parse(queryResult.responseText));
+ } catch(e) {
+ return Async.fail('Server returned invalid JSON for ' + url);
+ }
+ } else {
+ return Async.fail('Could not load page ' + url);
+ }
+ }
+ );
+}
+
+function getComments(articleKey) {
+ var threadId = blog.articles[articleKey].metadata.comments;
+ if(blog.urls.comments != undefined && threadId != undefined) {
+ var ul = Dom.make('ul');
+ var div = emptySection(ul);
+ Async.run(
+ Async.bind(
+ comments.get(threadId), Async.map(populateComments(div, ul))
+ )
+ );
+ return [div];
+ } else {
+ return [];
+ }
+}
+
+function populateComments(div, ul) {
+ return function(apiResults) {
+ var post = apiResults[0], comments = apiResults[1];
+ div.appendChild(post);
+ comments.forEach(function(comment) {ul.appendChild(comment);});
+ };
+}
+
+function emptySection(ul) {
+ return Dom.make('div', {class: 'comments'}, [
+ Dom.make('h2', {innerText: blog.wording.commentsSection}),
+ ul
+ ]);
+}
+
+function renderLink(post) {
+ return Dom.make('a', {
+ href: post.url,
+ innerText: blog.wording.commentsLink
+ });
+}
+
+function getContent(descendant) {
+ return descendant.content.replace(/:([^: ]+):/g, function(pattern, shortcode) {
+ var emoji = descendant.emojis.find(function(e) {return e.shortcode == shortcode;});
+ if(emoji) {
+ return [
+ '
'
+ ].join('"');
+ } else {
+ return pattern;
+ }
+ });
+}
+
+function renderAnswers(comments) {
+ return comments.descendants.map(function(descendant) {
+ return Dom.make('li', {}, [
+ Dom.make('a', {href: descendant.account.url}, [
+ Dom.make('img', {
+ src: descendant.account.avatar,
+ alt: descendant.account.username + "'s profile picture"
+ })
+ ]),
+ Dom.make('div', {
+ class: "metadata",
+ innerHTML: Template.render('metadata', {
+ author: author(descendant.account.url, descendant.account.username),
+ date: date(descendant.created_at)
+ })
+ }),
+ Dom.make('div', {innerHTML: getContent(descendant)})
+ ]);
+ });
+}
+
+function author(key, name) {
+ var authorUrl = key;
+ if(blog.articles[key] != undefined) {
+ authorUrl = blog.articles[key].metadata.author;
+ }
+ if(authorUrl) {
+ var author = name || authorUrl.replace(/.*\//, '');
+ return '' + author + '';
+ }
+}
+
+function date(key) {
+ if(blog.articles[key] != undefined) {
+ var date = new Date(blog.articles[key].metadata.date * 1000);
+ } else {
+ var date = new Date(key);
+ }
+ var format = blog.wording.dateFormat;
+ if(format[0] != '[') {
+ if(format[0] != '"') {
+ format = '"' + format + '"';
+ }
+ format = '[' + format + ']';
+ }
+ return Date.prototype.toLocaleDateString.apply(date, JSON.parse(format));
+}
+
+function tags(key) {
+ var tags = blog.articles[key].tagged;
+ return tags.length < 1 ? null : tags.map(function(tag) {
+ return '' + tag + '';
+ }).join(', ');
+}
+
+function get(key) {
+ return Dom.make('div', {
+ class: "metadata",
+ innerHTML: Template.render('metadata', {
+ author: author(key),
+ date: date(key),
+ tags: tags(key)
+ })
+ });
+}
diff --git a/share/js/Navigation.js b/share/js/Navigation.js
new file mode 100644
--- /dev/null
+++ b/share/js/Navigation.js
@@ -0,0 +1,121 @@
+import {articlesList, getResource, render} from DomRenderer;
+import blog from Hablo.Config;
+import * as Async from UnitJS.Async;
+import * as Cache from UnitJS.Cache;
+import * as Dom from UnitJS.Dom;
+import * as Fun from UnitJS.Fun;
+
+var cache = {};
+['article', 'page'].forEach(function(contentType) {
+ cache[contentType] = Cache.make(function(key) {
+ var url = ["", blog.path[contentType + 'sPath'], key + '.md'].join('/');
+ return Async.bind(
+ Async.http({method: 'GET', url: url}),
+ function(queryResult) {
+ if(queryResult.status == 200) {
+ return Async.wrap(queryResult.responseText);
+ } else {
+ return Async.fail(
+ "Could not load " + contentType + " " + url + " (" + queryResult.status + " " + queryResult.statusText + ")"
+ );
+ }
+ }
+ );
+ });
+});
+
+window.addEventListener('popstate', function(e) {
+ if(e.state != undefined) {
+ navigate(e.state.url);
+ }
+});
+history.replaceState({url: window.location.pathname}, 'Blog - title', window.location.pathname);
+return {
+ hijackLinks: hijackLinks
+};
+
+function hijackLinks(domElem) {
+ domElem = domElem || document;
+ var links = domElem.getElementsByTagName('a');
+ for(var i = 0; i < links.length; i++) {
+ var a = links[i];
+ var href = a.getAttribute("href");
+ if((href[0] == "/" && href.slice(-3) != ".md") || href[0] == "#") {
+ a.addEventListener('click', visit(a.getAttribute("href")));
+ }
+ }
+}
+
+function visit(url) {
+ return function(e) {
+ e.preventDefault();
+ if(url[0] == '#') {
+ window.location = url;
+ history.replaceState({url: window.location.pathname}, 'Blog - title', url);
+ } else {
+ navigate(url);
+ history.pushState({url: url}, 'Blog - title', url);
+ }
+ };
+}
+
+function navigate(url) {
+ var resource = getResource(url);
+ switch(resource.type) {
+ case 'list': show(getArticlesList(resource)); break;
+ case 'article':
+ case 'page': show(getCached(resource)); break;
+ default: console.log("No idea how to navigate to " + url);
+ }
+}
+
+function getCached(resource) {
+ return Async.bind(
+ cache[resource.type].get(resource.key),
+ Async.map(
+ function(contents) {return [render(resource, contents)];}
+ )
+ );
+}
+
+function preview(key) {
+ return Async.bind(
+ cache.article.get(key),
+ function(contents) {
+ return Async.wrap(
+ render({type: 'article', key: key}, contents, blog.skin.previewLinesCount)
+ );
+ }
+ );
+}
+
+function articleIds(resource) {
+ var ids = resource.tag != undefined ? blog.tags[resource.tag] : Object.keys(blog.articles);
+ var reverseDate = function (id) {return -blog.articles[id].metadata.date;};
+ ids.sort(Fun.compare(reverseDate));
+ return ids.slice(0, resource.all ? undefined : blog.skin.previewArticlesCount);
+}
+
+function getArticlesList(resource) {
+ return Async.bind(
+ Async.parallel.apply(null, articleIds(resource).map(preview)),
+ Async.map(articlesList(resource))
+ );
+}
+
+function show(contents) {
+ Async.run(
+ Async.bind(
+ contents,
+ Async.map(function (domElems) {
+ domElems = domElems.filter(Fun.defined);
+ var div = document.getElementById('contents');
+ Dom.clear(div);
+ for(var i = 0; i < domElems.length; i++) {
+ div.appendChild(domElems[i]);
+ }
+ hijackLinks(div);
+ })
+ )
+ );
+}
diff --git a/share/js/Remarkable.js b/share/js/Remarkable.js
new file mode 100644
--- /dev/null
+++ b/share/js/Remarkable.js
@@ -0,0 +1,8 @@
+import remarkableConfig from Hablo.Config;
+
+var md = new Remarkable(remarkableConfig);
+md.block.ruler.enable(['footnote']);
+
+return {
+ md: md
+};
diff --git a/share/js/Template.js b/share/js/Template.js
new file mode 100644
--- /dev/null
+++ b/share/js/Template.js
@@ -0,0 +1,35 @@
+import blog from Hablo.Config;
+
+return {
+ render: render
+};
+
+function render(template, environment) {
+ if(blog.wording[template] != undefined) {
+ var template = blog.wording[template];
+ }
+ template = template.replace(/{\?((?:[^?]|\?[^}])*)\?}/g, renderSub(environment));
+ var failed = [false];
+ var result = template.replace(
+ /([^$]|^)\$(?:{(\w+)}|(\w+)\b)/g,
+ substitute(environment, failed)
+ );
+ return failed[0] ? null : result;
+}
+
+function renderSub(environment) {
+ return function(_, sub) {
+ return render(sub, environment) || '';
+ };
+}
+
+function substitute(environment, failed) {
+ return function(_, before, bracketed, raw) {
+ var replaced = environment[bracketed || raw];
+ if(replaced != undefined) {
+ return before + replaced;
+ } else {
+ failed[0] = true;
+ }
+ }
+}
diff --git a/share/js/domRenderer.js b/share/js/domRenderer.js
deleted file mode 100644
--- a/share/js/domRenderer.js
+++ /dev/null
@@ -1,94 +0,0 @@
-function DomRenderer(modules) {
- return {
- article: article,
- articlesList: articlesList,
- replaceMarkdown: replaceMarkdown
- };
-
- function replaceMarkdown() {
- var div = document.getElementById('contents');
- if(div.children[0] && div.children[0].tagName.toLowerCase() == 'article') {
- convertArticle(div.children[0], true);
- } else {
- var articles = div.getElementsByClassName('articles')[0];
- if(articles != undefined) {
- for(var i = 0; i < articles.children.length; i++) {
- convertArticle(articles.children[i]);
- }
- } else {
- console.log('No articles found for this page');
- }
- }
- }
-
- function convertArticle(article, comments) {
- var header = article.getElementsByTagName('header')[0];
- header.appendChild(modules.metadata.get(article.id));
- var text = article.getElementsByTagName('pre')[0];
- if(text != undefined) {
- article.replaceChild(getDiv(text.innerText), text);
- if(comments) {
- modules.metadata.getComments(article.id)
- .forEach(article.appendChild.bind(article));
- }
- } else {
- console.log('No content found for this article');
- }
- }
-
- function getDiv(markdown) {
- var d= modules.dom.make('div', {
- innerHTML: modules.md.render(markdown)
- });
- var scripts = d.getElementsByTagName('script');
- for(var i = 0; i < scripts.length; i++) {
- var run = modules.dom.make('script',
- {type: 'text/javascript', src: scripts[i].src, textContent: scripts[i].textContent}
- );
- scripts[i].parentNode.replaceChild(run, scripts[i]);
- }
- return d;
- }
-
- function article(key, markdown, limit) {
- var url = ["", blog.path.articlesPath, key + (limit != undefined ? '.html' : '.md')].join('/');
- var lines = markdown.split(/\n/).slice(blog.articles[key].bodyOffset);
- var div = getDiv(lines.slice(0, limit).join('\n'));
- return modules.dom.make('article', {}, [
- modules.dom.make('header', {}, [
- modules.dom.make('a', {href: url}, [
- modules.dom.make('h1', {innerText: blog.articles[key].title})
- ]),
- modules.metadata.get(key)
- ]),
- div
- ].concat(limit != undefined ? [] : modules.metadata.getComments(key)));
- }
-
- 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'];
- }
- }
-
- function otherUrl(tag, all) {
- var path = [tag, all ? null : 'all.html'];
- return '/' + path.filter(modules.fun.defined).join('/');
- }
-
- 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))
- ];
- };
- }
-}
diff --git a/share/js/main.js b/share/js/main.js
deleted file mode 100644
--- a/share/js/main.js
+++ /dev/null
@@ -1,14 +0,0 @@
-window.addEventListener('load', function() {
- var async = unitJS.Async();
- var cache = unitJS.Cache();
- var dom = unitJS.Dom();
- var fun = unitJS.Fun();
- var md = new Remarkable(remarkableConfig);
- md.block.ruler.enable(['footnote']);
- var template = Template();
- var metadata = Metadata({async: async, cache: cache, dom: dom, fun:fun, template: template});
- var domRenderer = DomRenderer({dom: dom, fun: fun, md: md, metadata: metadata, template: template});
- var navigation = Navigation({async: async, cache: cache, dom: dom, domRenderer: domRenderer, fun: fun, md: md});
- domRenderer.replaceMarkdown();
- navigation.hijackLinks();
-});
diff --git a/share/js/metadata.js b/share/js/metadata.js
deleted file mode 100644
--- a/share/js/metadata.js
+++ /dev/null
@@ -1,155 +0,0 @@
-function Metadata(modules) {
- var comments = modules.cache.make(function(threadId) {
- return modules.async.bind(
- modules.async.parallel(
- getJSON(url(threadId)),
- getJSON(url(threadId) + '/context'),
- ),
- modules.async.map(function(t) {
- return [renderLink(t[0]), renderAnswers(t[1])];
- })
- );
- });
- return {
- get: get,
- getComments: getComments
- };
-
- function url(threadId) {
- return blog.path.commentsAt + '/api/v1/statuses/' + threadId;
- }
-
- function getJSON(url) {
- return modules.async.bind(
- modules.async.http({method: 'GET', url: url}),
- function(queryResult) {
- if(queryResult.status == 200) {
- try {
- return modules.async.wrap(JSON.parse(queryResult.responseText));
- } catch(e) {
- return modules.async.fail('Server returned invalid JSON for ' + url);
- }
- } else {
- return modules.async.fail('Could not load page ' + url);
- }
- }
- );
- }
-
- function getComments(articleKey) {
- var threadId = blog.articles[articleKey].metadata.comments;
- if(blog.path.commentsAt != undefined && threadId != undefined) {
- var ul = modules.dom.make('ul');
- var div = emptySection(ul);
- modules.async.run(
- modules.async.bind(
- comments.get(threadId), modules.async.map(populateComments(div, ul))
- )
- );
- return [div];
- } else {
- return [];
- }
- }
-
- function populateComments(div, ul) {
- return function(apiResults) {
- var post = apiResults[0], comments = apiResults[1];
- div.appendChild(post);
- comments.forEach(function(comment) {ul.appendChild(comment);});
- };
- }
-
- function emptySection(ul) {
- return modules.dom.make('div', {class: 'comments'}, [
- modules.dom.make('h2', {innerText: blog.wording.commentsSection}),
- ul
- ]);
- }
-
- function renderLink(post) {
- return modules.dom.make('a', {
- href: post.url,
- innerText: blog.wording.commentsLink
- });
- }
-
- function getContent(descendant) {
- return descendant.content.replace(/:([^: ]+):/g, function(pattern, shortcode) {
- var emoji = descendant.emojis.find(function(e) {return e.shortcode == shortcode;});
- if(emoji) {
- return [
- ''
- ].join('"');
- } else {
- return pattern;
- }
- });
- }
-
- function renderAnswers(comments) {
- return comments.descendants.map(function(descendant) {
- return modules.dom.make('li', {}, [
- modules.dom.make('a', {href: descendant.account.url}, [
- modules.dom.make('img', {
- src: descendant.account.avatar,
- alt: descendant.account.username + "'s profile picture"
- })
- ]),
- modules.dom.make('div', {
- class: "metadata",
- innerHTML: modules.template.render('metadata', {
- author: author(descendant.account.url, descendant.account.username),
- date: date(descendant.created_at)
- })
- }),
- modules.dom.make('div', {innerHTML: getContent(descendant)})
- ]);
- });
- }
-
- function author(key, name) {
- var authorUrl = key;
- if(blog.articles[key] != undefined) {
- authorUrl = blog.articles[key].metadata.author;
- }
- if(authorUrl) {
- var author = name || authorUrl.replace(/.*\//, '');
- return '' + author + '';
- }
- }
-
- function date(key) {
- if(blog.articles[key] != undefined) {
- var date = new Date(blog.articles[key].metadata.date * 1000);
- } else {
- var date = new Date(key);
- }
- var format = blog.wording.dateFormat;
- if(format[0] != '[') {
- if(format[0] != '"') {
- format = '"' + format + '"';
- }
- format = '[' + format + ']';
- }
- return Date.prototype.toLocaleDateString.apply(date, JSON.parse(format));
- }
-
- function tags(key) {
- var tags = blog.articles[key].tagged;
- return tags.length < 1 ? null : tags.map(function(tag) {
- return '' + tag + '';
- }).join(', ');
- }
-
- function get(key) {
- return modules.dom.make('div', {
- class: "metadata",
- innerHTML: modules.template.render('metadata', {
- author: author(key),
- date: date(key),
- tags: tags(key)
- })
- });
- }
-}
diff --git a/share/js/navigation.js b/share/js/navigation.js
deleted file mode 100644
--- a/share/js/navigation.js
+++ /dev/null
@@ -1,117 +0,0 @@
-function Navigation(modules) {
- var articles = modules.cache.make(function(key) {
- var url = ["", blog.path.articlesPath, key + '.md'].join('/');
- return modules.async.bind(
- modules.async.http({method: 'GET', url: url}),
- function(queryResult) {
- if(queryResult.status == 200) {
- return modules.async.wrap(queryResult.responseText);
- } else {
- return modules.async.fail(
- "Could not load article " + url + " (" + queryResult.status + " " + queryResult.statusText + ")"
- );
- }
- }
- );
- });
- window.addEventListener('popstate', function(e) {
- if(e.state != undefined) {
- navigate(e.state.url);
- }
- });
- history.replaceState({url: window.location.pathname}, 'Blog - title', window.location.pathname);
- return {
- hijackLinks: hijackLinks
- };
-
- function hijackLinks(domElem) {
- domElem = domElem || document;
- var links = domElem.getElementsByTagName('a');
- for(var i = 0; i < links.length; i++) {
- var a = links[i];
- var href = a.getAttribute("href");
- if((href[0] == "/" && href.slice(-3) != ".md") || href[0] == "#") {
- a.addEventListener('click', visit(a.getAttribute("href")));
- }
- }
- }
-
- function visit(url) {
- return function(e) {
- e.preventDefault();
- if(url[0] == '#') {
- window.location = url;
- history.replaceState({url: window.location.pathname}, 'Blog - title', url);
- } else {
- navigate(url);
- history.pushState({url: url}, 'Blog - title', url);
- }
- };
- }
-
- function navigate(url) {
- var path = decodeURI(url).split("/").slice(1);
- if(blog.tags[path[0]] != undefined) {
- show(getArticlesList(path[0], path[1] == "all.html"));
- } else if(path[0] == blog.path.articlesPath) {
- show(getArticle(path[1].replace(/\.html$/, '')));
- } else {
- show(getArticlesList(null, path[0] == "all.html"));
- }
- }
-
- function getArticle(key) {
- return modules.async.bind(
- articles.get(key),
- modules.async.map(
- function(contents) {return [modules.domRenderer.article(key, contents)];}
- )
- );
- }
-
- function preview(key) {
- return modules.async.bind(
- articles.get(key),
- function(contents) {
- return modules.async.wrap(
- modules.domRenderer.article(
- key,
- contents,
- blog.skin.previewLinesCount
- )
- );
- }
- );
- }
-
- function articleIds(tag, all) {
- var ids = tag != undefined ? blog.tags[tag] : Object.keys(blog.articles);
- var reverseDate = function (id) {return -blog.articles[id].metadata.date;};
- ids.sort(modules.fun.compare(reverseDate));
- return ids.slice(0, all ? undefined : blog.skin.previewArticlesCount);
- }
-
- function getArticlesList(tag, all) {
- return modules.async.bind(
- modules.async.parallel.apply(null, articleIds(tag, all).map(preview)),
- modules.async.map(modules.domRenderer.articlesList(tag, all))
- );
- }
-
- function show(contents) {
- modules.async.run(
- modules.async.bind(
- contents,
- modules.async.map(function (domElems) {
- domElems = domElems.filter(modules.fun.defined);
- var div = document.getElementById('contents');
- modules.dom.clear(div);
- for(var i = 0; i < domElems.length; i++) {
- div.appendChild(domElems[i]);
- }
- hijackLinks(div);
- })
- )
- );
- }
-}
diff --git a/share/js/template.js b/share/js/template.js
deleted file mode 100644
--- a/share/js/template.js
+++ /dev/null
@@ -1,35 +0,0 @@
-function Template() {
- return {
- render: render
- };
-
- function render(template, environment) {
- if(blog.wording[template] != undefined) {
- var template = blog.wording[template];
- }
- template = template.replace(/\${\?((?:[^?]|\?[^}])*)\?}/g, renderSub(environment));
- var failed = [false];
- var result = template.replace(
- /([^$]|^)\$(?:{(\w+)}|(\w+)\b)/g,
- substitute(environment, failed)
- );
- return failed[0] ? null : result;
- }
-
- function renderSub(environment) {
- return function(_, sub) {
- return render(sub, environment) || '';
- };
- }
-
- function substitute(environment, failed) {
- return function(_, before, bracketed, raw) {
- var replaced = environment[bracketed || raw];
- if(replaced != undefined) {
- return before + replaced;
- } else {
- failed[0] = true;
- }
- }
- }
-}
diff --git a/src/Arguments.hs b/src/Arguments.hs
--- a/src/Arguments.hs
+++ b/src/Arguments.hs
@@ -1,29 +1,38 @@
+{-# LANGUAGE CPP #-}
module Arguments (
Arguments(..)
, get
) where
+#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
+#endif
import Data.Version (showVersion)
import Control.Applicative ((<|>), (<**>), optional)
-import Options.Applicative (Parser, ReadM, argument, auto, eitherReader, execParser, flag', fullDesc, header, help, helper, info, long, metavar, short, str, value)
+import Options.Applicative (
+ Parser, ReadM, argument, auto, eitherReader, execParser, flag', fullDesc
+ , header, help, helper, info, long, metavar, short, str, switch, value
+ )
import qualified Options.Applicative as Optparse (option)
import qualified Paths_hablo as Hablo (version)
import System.FilePath (dropTrailingPathSeparator, isValid)
data Arguments = BlogConfig {
sourceDir :: FilePath
- , articlesPath :: FilePath
+ , articlesPath :: Maybe FilePath
, bannerPath :: Maybe FilePath
, cardImage :: Maybe FilePath
- , commentsAt :: Maybe String
+ , commentsURL :: Maybe String
, favicon :: Maybe FilePath
, headPath :: Maybe FilePath
, name :: Maybe String
+ , openGraphCards :: Bool
, pagesPath :: Maybe FilePath
, previewArticlesCount :: Int
, previewLinesCount :: Int
, remarkableConfig :: Maybe FilePath
+ , rss :: Bool
+ , siteURL :: Maybe String
, wording :: Maybe FilePath
}
| Version
@@ -41,21 +50,17 @@
blogConfig :: Parser Arguments
blogConfig = BlogConfig
<$> argument filePath (value "." <> metavar "INPUT_DIR")
- <*> Optparse.option filePath (
- metavar "DIRECTORY"
- <> value "articles"
- <> short 'a'
- <> long "articles"
- <> help "relative path to the directory containing the articles within INPUT_DIR"
- )
+ <*> option filePath 'a' "articles" "DIRECTORY"
+ "relative path to the directory containing the articles within INPUT_DIR"
<*> option filePath 'b' "banner" "FILE" "path to the file to use for the blog's banner"
<*> option filePath 'c' "card-image" "FILE" "relative path to the image to use for the blog's card"
- <*> option filePath 'C' "comments-at" "URL" "url of the instance where comments are stored"
+ <*> option filePath 'C' "comments-url" "URL" "URL of the instance where comments are stored"
<*> option filePath 'f' "favicon" "FILE" "path to the image to use for the blog's favicon"
<*> option filePath 'H' "head" "FILE" "path to the file to add in the blog's head"
<*> option str 'n' "name" "BLOG_NAME" "name of the blog"
- <*> option filePath 'p' "pages"
- "DIRECTORY" "relative path to the directory containing the pages within INPUT_DIR"
+ <*> switch (short 'O' <> long "open-graph-cards" <> help "enable Open Graph cards")
+ <*> option filePath 'p' "pages" "DIRECTORY"
+ "relative path to the directory containing the pages within INPUT_DIR"
<*> Optparse.option auto (
metavar "INTEGER"
<> value 3
@@ -72,6 +77,8 @@
)
<*> option filePath 'r' "remarkable-config" "FILE"
"path to a file containing a custom RemarkableJS configuration"
+ <*> switch (short 'R' <> long "rss" <> help "enable RSS feeds generation")
+ <*> option filePath 'u' "site-url" "URL" "URL where the blog is published"
<*> option filePath 'w' "wording" "FILE" "path to the file containing the wording to use"
version :: Parser Arguments
diff --git a/src/Article.hs b/src/Article.hs
--- a/src/Article.hs
+++ b/src/Article.hs
@@ -1,75 +1,23 @@
{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE FlexibleContexts #-}
module Article (
Article(..)
, at
- , getKey
, preview
) where
import Control.Applicative ((<|>))
-import Data.Map (Map)
-import qualified Data.Map as Map (fromList, alter)
+import qualified Data.Map as Map (alter)
import Data.Time (defaultTimeLocale, getCurrentTimeZone, parseTimeM, timeZoneOffsetString)
import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
import Foreign.C.Types (CTime)
-import System.FilePath (dropExtension, takeFileName)
+import Markdown (Markdown(..), MarkdownContent(..), Metadata)
+import qualified Markdown (at)
import System.Posix.Files (getFileStatus, modificationTime)
-import Text.ParserCombinators.Parsec (
- ParseError
- , Parser
- , ()
- , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf
- , oneOf, option, parse, skipMany, sourceLine, string, try
- )
-
-type Metadata = Map String String
-
-data Article = Article {
- key :: String
- , title :: String
- , metadata :: Metadata
- , bodyOffset :: Int
- , body :: [String]
- }
-
-type ProtoArticle = (String, Metadata, Int, [String])
-
-articleP :: Parser ProtoArticle
-articleP =
- skipMany eol *> headerP <* skipMany eol <*> lineOffset <*> bodyP
- where
- headerP =
- try ((,,,) <$> titleP <* many eol <*> metadataP)
- <|> flip (,,,) <$> metadataP <* many eol<*> titleP
- lineOffset = pred . sourceLine <$> getPosition
- bodyP = lines <$> many anyChar <* eof
-
-metadataP :: Parser Metadata
-metadataP = Map.fromList <$> option [] (
- metaSectionSeparator *> many eol *>
- (try keyVal) `endBy` (many1 eol)
- <* metaSectionSeparator
- ) "metadata section"
- where
- metaSectionSeparator = count 3 (oneOf "~-") *> eol
- spaces = skipMany $ char ' '
- keyVal = (,) <$> (no ": \r\n" <* spaces <* char ':' <* spaces) <*> no "\r\n"
-
-titleP :: Parser String
-titleP = try (singleLine <|> underlined)
- where
- singleLine = char '#' *> char ' ' *> no "\r\n" <* eol
- underlined =
- no "\r\n" <* eol
- >>= \titleLine -> count (length titleLine) (oneOf "#=") *> eol *> return titleLine
- "'#' or '=' to underline the title"
-
-eol :: Parser String
-eol = try (string "\r\n") <|> string "\r" <|> string "\n" "newline"
+import Text.ParserCombinators.Parsec (ParseError)
-no :: String -> Parser String
-no = many1 . noneOf
+newtype Article = Article Markdown
+instance MarkdownContent Article where
+ getMarkdown (Article markdown) = markdown
setDate :: String -> CTime -> Metadata -> Metadata
setDate tzOffset defaultDate = Map.alter timeStamp "date"
@@ -82,27 +30,16 @@
let parsedTimes = parseTimeM True defaultTimeLocale <$> formats <*> dates in
foldr (<|>) (timeStamp Nothing) (fmap epoch <$> parsedTimes)
-makeArticle :: FilePath -> (Metadata -> Metadata) -> ProtoArticle -> (String, Article)
-makeArticle filePath metaFilter (title, metadata, bodyOffset, body) = (
- getKey filePath
- , Article {
- key = getKey filePath
- , title
- , metadata = metaFilter metadata
- , bodyOffset
- , body
- }
- )
+makeArticle :: (Metadata -> Metadata) -> Markdown -> (String, Article)
+makeArticle metaFilter markdown@(Markdown {key, metadata}) =
+ (key, Article $ markdown {metadata = metaFilter metadata})
at :: FilePath -> IO (Either ParseError (String, Article))
at filePath = do
tzOffset <- timeZoneOffsetString <$> getCurrentTimeZone
fileDate <- modificationTime <$> getFileStatus filePath
- let build = makeArticle filePath (setDate tzOffset fileDate)
- fmap build . parse articleP filePath <$> readFile filePath
-
-getKey :: FilePath -> String
-getKey = dropExtension . takeFileName
+ fmap (makeArticle (setDate tzOffset fileDate)) <$> Markdown.at filePath
-preview :: Int -> Article -> Article
-preview linesCount article = article {body = take linesCount $ body article}
+preview :: Int -> Article -> Markdown
+preview linesCount (Article markdown@(Markdown {body})) =
+ markdown {body = take linesCount $ body}
diff --git a/src/ArticlesList.hs b/src/ArticlesList.hs
--- a/src/ArticlesList.hs
+++ b/src/ArticlesList.hs
@@ -3,35 +3,46 @@
{-# LANGUAGE FlexibleContexts #-}
module ArticlesList (
ArticlesList(..)
- , otherUrl
- , pageTitle
+ , description
+ , getArticles
+ , otherURL
+ , rssLinkTexts
) where
import Article (Article)
-import Blog (Blog(..), Wording(..), get)
-import Control.Monad.Reader (MonadReader)
+import Blog (Blog(..), Renderer, Skin(..), template)
+import Collection (Collection(..))
+import Control.Monad.Reader (MonadReader, asks)
import Data.Text (Text, pack)
-import Data.Text.Lazy (toStrict)
-import Data.Text.Template (render)
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
-pageTitle :: (MonadReader Blog m) => ArticlesList -> m Text
-pageTitle (ArticlesList {full, tagged}) = do
- template <- Blog.get $wording.$(if full then allTaggedPage else latestTaggedPage)
- untagged <- Blog.get $wording.$(if full then allPage else latestPage)
- return $ maybe untagged (toStrict . render template . tag) tagged
+otherURL :: ArticlesList -> String
+otherURL (ArticlesList {full, collection}) = absoluteLink $
+ (if full then id else ( "all.html")) . maybe "" id $ tag collection
+
+description :: Renderer m => ArticlesList -> m Text
+description (ArticlesList {full, collection}) =
+ template page . environment $ tag collection
where
- tag :: String -> Text -> Text
- tag t = \"tag" -> pack t
+ 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
--- a/src/Blog.hs
+++ b/src/Blog.hs
@@ -1,95 +1,126 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
module Blog (
Blog(..)
, Path(..)
+ , Renderer
, Skin(..)
- , Wording(..)
+ , URL(..)
+ , Wording
, build
- , get
+ , template
) where
import Arguments (Arguments)
import qualified Arguments (name, sourceDir)
import Article (Article)
-import qualified Article (at, getKey)
+import qualified Article (at)
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.Wording (Wording(..))
+import Blog.URL (URL(..))
+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 Files (File(..), absolute)
+import Data.Text (Text)
+import Files (File(..), filePath)
import qualified Files (find)
+import Markdown (getKey)
+import Page (Page)
+import qualified Page (at)
import Prelude hiding (lookup)
-import System.Directory (doesFileExist, withCurrentDirectory)
+import Pretty (assertRight, onRight)
+import System.Directory (doesFileExist, makeAbsolute, withCurrentDirectory)
import System.FilePath ((), dropTrailingPathSeparator, takeExtension, takeFileName)
import Text.Parsec (ParseError)
-type Collection = Map String Article
+type Collection = Map String
+type Parsed a = Either ParseError (String, a)
data Blog = Blog {
- articles :: Collection
+ articles :: Collection Article
+ , hasRSS :: Bool
, name :: String
+ , pages :: Collection Page
, path :: Path
, skin :: Skin
- , tags :: Map String (Set String)
+ , tags :: Collection (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)
-keepOrWarn :: Map String Article -> Either ParseError (String, Article) -> IO (Map String Article)
+template :: Renderer m => String -> Environment -> m Text
+template key environment = asks templates >>= render key environment
+
+keepOrWarn :: Collection a -> Parsed a -> IO (Collection a)
keepOrWarn accumulator (Left parseErrors) =
- forM [show parseErrors, "=> Ignoring this article"] putStrLn
+ forM [show parseErrors, "=> Ignoring this text"] putStrLn
>> return accumulator
keepOrWarn accumulator (Right (key, article)) =
return $ insert key article accumulator
-findArticles :: FilePath -> IO (Map String Article)
-findArticles =
+find :: (FilePath -> IO (Parsed a)) -> FilePath -> IO (Collection a)
+find parser =
Files.find
>=> filterM isMarkDownFile
- >=> mapM Article.at
+ >=> mapM parser
>=> foldM keepOrWarn Map.empty
where
isMarkDownFile path = do
let correctExtension = takeExtension path == ".md"
(correctExtension &&) <$> doesFileExist path
-tagged :: Collection -> FilePath -> IO (String, Set String)
+tagged :: Collection Article -> FilePath -> IO (String, Set String)
tagged collection path = do
links <- Files.find path
keys <- forM links $ \link -> do
fileExists <- doesFileExist link
return $ if fileExists
- then let articleKey = Article.getKey link in
+ then let articleKey = getKey link in
maybe Set.empty (\_ -> Set.singleton articleKey) (lookup articleKey collection)
else Set.empty
return (takeFileName path, foldl Set.union Set.empty keys)
-discover :: Path -> IO (Collection, Map String (Set String))
+discover :: Path -> IO (Collection Article, Collection Page, Collection (Set String))
discover path = do
- articles <- findArticles $ articlesPath path
- tags <- Map.fromList . filter (not . Set.null . snd)
- <$> (Files.find (articlesPath path "tags") >>= mapM (articles `tagged`))
- return (articles, tags)
+ (articles, tags) <- discoverArticles $ articlesPath path
+ pages <- maybe (return Map.empty) (find Page.at) $ pagesPath path
+ return (articles, pages, tags)
+ where
+ discoverArticles Nothing = return (Map.empty, Map.empty)
+ discoverArticles (Just somePath) = do
+ articles <- find Article.at somePath
+ tags <- Map.fromList . filter (not . Set.null . snd)
+ <$> (Files.find (somePath "tags") >>= mapM (articles `tagged`))
+ return (articles, tags)
build :: Arguments -> IO Blog
build arguments = do
+ urls <- URL.build arguments
+ let hasRSS = maybe False (\_-> True) $ rss urls
wording <- Wording.build arguments
- root <- Files.absolute . Dir $ Arguments.sourceDir arguments
+ templates <- Template.build wording
+ root <- onRight makeAbsolute =<< filePath (Dir $ Arguments.sourceDir arguments)
withCurrentDirectory root $ do
- path <- Path.build root arguments
+ path <- assertRight =<< 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, wording}
+ (articles, pages, tags) <- discover path
+ return $ Blog {
+ articles, hasRSS, name, pages, path, skin, tags, templates, urls, wording
+ }
diff --git a/src/Blog/Path.hs b/src/Blog/Path.hs
--- a/src/Blog/Path.hs
+++ b/src/Blog/Path.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
module Blog.Path (
Path(..)
, build
@@ -8,33 +9,44 @@
import Arguments (Arguments)
import qualified Arguments as Arguments (Arguments(..))
+import Control.Monad (join)
+import Control.Monad.Except (MonadError(..), ExceptT(..), runExceptT)
import Data.Aeson (ToJSON(..), (.=), pairs)
+#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
+#endif
import Files (File(..), filePath)
import GHC.Generics (Generic)
data Path = Path {
- articlesPath :: FilePath
- , commentsAt :: Maybe String
+ articlesPath :: Maybe FilePath
, pagesPath :: Maybe FilePath
, remarkableConfig :: Maybe FilePath
, root :: FilePath
- } deriving Generic
+ } deriving (Eq, Generic, Show)
instance ToJSON Path where
- toEncoding (Path {articlesPath, commentsAt, pagesPath}) = pairs (
+ toEncoding (Path {articlesPath, pagesPath}) = pairs (
"articlesPath" .= articlesPath
- <> "commentsAt" .= commentsAt
<> "pagesPath" .= pagesPath
)
-build :: FilePath -> Arguments -> IO Path
-build root arguments = do
- articlesPath <- filePath . Dir $ Arguments.articlesPath arguments
- pagesPath <- mapM (filePath . Dir) $ Arguments.pagesPath arguments
- remarkableConfig <- mapM (filePath . File) $ Arguments.remarkableConfig arguments
- return $ Path {
- articlesPath, commentsAt, pagesPath, remarkableConfig, root
- }
+checkFor :: (FilePath -> File) -> FilePath -> ExceptT String IO (Maybe FilePath)
+checkFor fileOrDir = ExceptT . fmap (Just <$>) . filePath . fileOrDir
+
+getMarkdownPath :: FilePath -> Maybe FilePath -> ExceptT String IO (Maybe FilePath)
+getMarkdownPath defaultPath Nothing =
+ ExceptT . (Right . either (\_ -> Nothing) Just <$>) . filePath $ Dir defaultPath
+getMarkdownPath _ (Just customPath) = checkFor Dir customPath
+
+build :: FilePath -> Arguments -> IO (Either String Path)
+build root arguments = runExceptT . join $ pack
+ <$> getMarkdownPath "articles" (Arguments.articlesPath arguments)
+ <*> getMarkdownPath "pages" (Arguments.pagesPath arguments)
+ <*> maybe ignore (checkFor File) (Arguments.remarkableConfig arguments)
where
- commentsAt = Arguments.commentsAt arguments
+ pack Nothing Nothing _ =
+ throwError "No articles ? No pages ? Why did you wake me up ? I'm going back to sleep"
+ pack articlesPath pagesPath remarkableConfig =
+ return $ Path {articlesPath, pagesPath, remarkableConfig, root}
+ ignore = return Nothing
diff --git a/src/Blog/Skin.hs b/src/Blog/Skin.hs
--- a/src/Blog/Skin.hs
+++ b/src/Blog/Skin.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
module Blog.Skin (
Skin(..)
, build
@@ -11,7 +12,9 @@
import Control.Monad (filterM)
import Data.Aeson (ToJSON(..), (.=), pairs)
import Data.Maybe (listToMaybe)
+#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
+#endif
import Files (absoluteLink)
import GHC.Generics (Generic)
import Prelude hiding (head)
@@ -36,7 +39,7 @@
findImage :: String -> Maybe FilePath -> IO (Maybe FilePath)
findImage _ (Just path) = return . Just $ absoluteLink path
findImage name Nothing =
- fmap absoluteLink . listToMaybe <$> filterM doesFileExist pathsToCheck
+ listToMaybe <$> filterM doesFileExist pathsToCheck
where
directories = [".", "image", "images", "pictures", "skin", "static"]
extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"]
diff --git a/src/Blog/Template.hs b/src/Blog/Template.hs
new file mode 100644
--- /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/URL.hs b/src/Blog/URL.hs
new file mode 100644
--- /dev/null
+++ b/src/Blog/URL.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Blog.URL (
+ URL(..)
+ , build
+ ) where
+
+import Arguments (Arguments)
+import qualified Arguments as Arguments (Arguments(..))
+import Data.Aeson (ToJSON(..), (.=), pairs)
+import GHC.Generics (Generic)
+import System.Exit (die)
+import System.IO (hPutStrLn, stderr)
+import Text.Printf (printf)
+
+data URL = URL {
+ cards :: Maybe String
+ , comments :: Maybe String
+ , rss :: Maybe String
+ } deriving Generic
+
+instance ToJSON URL where
+ toEncoding (URL {comments}) = pairs (
+ "comments" .= comments
+ )
+
+build :: Arguments -> IO URL
+build arguments = do
+ cards <- getSiteURL argOGCards "Open Graph cards"
+ rss <- getSiteURL argRSS "RSS feeds"
+ checksUsed (argOGCards || argRSS) siteURL
+ return $ URL {cards, comments, rss}
+ where
+ comments = Arguments.commentsURL arguments
+ siteURL = Arguments.siteURL arguments
+ argOGCards = Arguments.openGraphCards arguments
+ argRSS = Arguments.rss arguments
+ errorMsg :: String -> String
+ errorMsg = printf "Enabling %s requires setting the site url with --site-url"
+ getSiteURL False _ = return Nothing
+ getSiteURL True name = maybe (die $ errorMsg name) (return . Just) siteURL
+ checksUsed False (Just _) =
+ hPutStrLn stderr "Site url is set but not used, did you forget --open-graph-cards or --rss ?"
+ checksUsed _ _ = return ()
diff --git a/src/Blog/Wording.hs b/src/Blog/Wording.hs
--- a/src/Blog/Wording.hs
+++ b/src/Blog/Wording.hs
@@ -1,20 +1,17 @@
-{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Blog.Wording (
Wording(..)
, build
+ , variables
) where
import Arguments (Arguments(..))
import Control.Monad (foldM)
-import Data.Aeson (ToJSON(..), (.=), object, pairs)
-import Data.List (intercalate)
-import Data.Map (Map, (!))
-import qualified Data.Map as Map (empty, fromList, map, union)
-import Data.Monoid ((<>))
+import Data.Aeson (ToJSON(..))
+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.Template (Template, renderA, showTemplate, templateSafe)
+import qualified Data.Text as Text (pack)
import Paths_hablo (getDataFileName)
import Text.ParserCombinators.Parsec (
Parser
@@ -23,40 +20,29 @@
)
import System.Exit (die)
-data Wording = Wording {
- allLink :: Text
- , allPage :: Text
- , allTaggedPage :: Template
- , commentsLink :: Text
- , commentsSection :: Text
- , dateFormat :: Text
- , latestLink :: Text
- , latestPage :: Text
- , latestTaggedPage :: Template
- , metadata :: Text
- , tagsList :: Text
- }
-
-keys :: [String]
-keys = [
- "allLink", "allPage", "allTaggedPage", "commentsLink", "commentsSection"
- , "dateFormat", "latestLink", "latestPage", "latestTaggedPage", "metadata"
- , "tagsList"
- ]
+newtype Wording = Wording (Map String Text)
-values :: [Wording -> Text]
-values = [
- allLink, allPage, showTemplate . allTaggedPage, commentsLink, commentsSection
- , dateFormat, latestLink, latestPage, showTemplate . latestTaggedPage
- , metadata, tagsList
+variables :: Map String [Text]
+variables = Map.fromList [
+ ("allLink", [])
+ , ("allPage", ["tag"])
+ , ("articleDescription", ["name"])
+ , ("commentsLink", [])
+ , ("commentsSection", [])
+ , ("dateFormat", [])
+ , ("latestLink", [])
+ , ("latestPage", ["tag"])
+ , ("metadata", ["author", "date", "tags"])
+ , ("pageDescription", ["name"])
+ , ("pagesList", [])
+ , ("rssLink", [])
+ , ("rssTitle", ["tag"])
+ , ("tagsList", [])
]
-texts :: Wording -> [Text]
-texts wording = ($ wording) <$> values
-
instance ToJSON Wording where
- toJSON = object . zipWith (.=) (Text.pack <$> keys) . texts
- toEncoding = pairs . foldl (<>) mempty . zipWith (.=) (Text.pack <$> keys) . texts
+ toJSON (Wording m) = toJSON m
+ toEncoding (Wording m) = toEncoding m
addWording :: Map String Text -> FilePath -> IO (Map String Text)
addWording currentWording wordingFile = do
@@ -72,41 +58,12 @@
restOfLine = many $ noneOf "\r\n"
eol = try (string "\r\n") <|> string "\r" <|> string "\n"
skip = optional (char '#' *> restOfLine) *> eol
- line = (,) <$> (choice (try . string <$> keys) <* equal) <*> restOfLine
+ varEqual = choice (try . string <$> Map.keys variables) <* equal
+ line = (,) <$> varEqual <*> restOfLine
equal = many (char ' ') *> char '=' *> many (char ' ')
-checkTemplateWith :: [Text] -> String -> Map String Text -> IO Template
-checkTemplateWith variables key wording =
- let templateText = wording ! key in
- let testEnvironment = flip lookup [(s, "") | s <- variables] 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 =
- " (available variables: " ++ intercalate ", " (Text.unpack <$> variables) ++ ")"
- syntaxError row col =
- "Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col
- badTemplate = "Invalid template for variable " ++ key ++ availableVariables
-
build :: Arguments -> IO Wording
build arguments = do
defaultWording <- getDataFileName "defaultWording.conf"
let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
- wording <- foldM addWording Map.empty wordingFiles
- allTaggedPage <- checkTemplateWith ["tag"] "allTaggedPage" wording
- latestTaggedPage <- checkTemplateWith ["tag"] "latestTaggedPage" wording
- return Wording {
- allLink = wording ! "allLink"
- , allPage = wording ! "allPage"
- , allTaggedPage
- , commentsLink = wording ! "commentsLink"
- , commentsSection = wording ! "commentsSection"
- , dateFormat = wording ! "dateFormat"
- , latestLink = wording ! "latestLink"
- , latestPage = wording ! "latestPage"
- , latestTaggedPage
- , metadata = wording ! "metadata"
- , tagsList = wording ! "tagsList"
- }
+ Wording <$> foldM addWording Map.empty wordingFiles
diff --git a/src/Collection.hs b/src/Collection.hs
new file mode 100644
--- /dev/null
+++ b/src/Collection.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Collection (
+ Collection(..)
+ , getAll
+ , title
+ ) where
+
+import Article(Article)
+import Blog (Blog(..), Path(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Reader (MonadReader(..), ReaderT, asks)
+import Data.List (sortOn)
+import Data.Map ((!))
+import qualified Data.Map as Map (elems, filterWithKey, toList)
+import Data.Ord (Down(..))
+import qualified Data.Set as Set (member)
+import Markdown (Markdown(metadata), MarkdownContent(..))
+import Pretty ((.$))
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath (())
+
+data Collection = Collection {
+ featured :: [Article]
+ , basePath :: FilePath
+ , tag :: Maybe String
+ }
+
+build :: MonadIO m => [Article] -> Maybe String -> ReaderT Blog m Collection
+build featured tag = do
+ root <- asks $path.$root
+ let basePath = maybe root (root ) tag
+ liftIO $ createDirectoryIfMissing False basePath
+ return $ Collection {
+ featured = sortByDate featured, basePath, tag
+ }
+ where
+ sortByDate = sortOn (Down . (! "date") . metadata . getMarkdown)
+
+getAll :: ReaderT Blog IO [Collection]
+getAll = do
+ Blog {articles, tags} <- ask
+ (:)
+ <$> (build (Map.elems articles) Nothing)
+ <*> (flip mapM (Map.toList tags) $
+ \(tag, tagged) -> build (getArticles tagged articles) $ Just tag
+ )
+ 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
new file mode 100644
--- /dev/null
+++ b/src/DOM.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module DOM (
+ HasContent(..)
+ , htmlDocument
+ ) where
+
+import Article (Article)
+import qualified Article (preview)
+import ArticlesList (
+ ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
+ )
+import Blog (Blog(..), Skin(..), URL(..), template)
+import Control.Monad.Reader (ReaderT, asks)
+import Data.Map as Map (Map, toList)
+import Data.Text (Text, pack, empty)
+import DOM.Card (HasCard)
+import qualified DOM.Card as Card (make)
+import Files (absoluteLink)
+import Lucid (
+ HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_, h1_, h2_
+ , head_, header_, href_, li_, link_, id_, meta_, pre_, rel_, script_, src_
+ , title_, toHtml, toHtmlRaw, type_, ul_
+ )
+import Markdown (Markdown(..), MarkdownContent(..))
+import Page (Page)
+import Prelude hiding (head, lookup)
+import Pretty ((.$))
+import System.FilePath.Posix ((<.>))
+
+type HtmlGenerator = HtmlT (ReaderT Blog IO)
+
+class HasCard a => HasContent a where
+ content :: a -> HtmlGenerator ()
+
+instance HasContent Article where
+ content = mDContent True . getMarkdown
+
+instance HasContent Page where
+ content = mDContent True . getMarkdown
+
+instance HasContent ArticlesList where
+ content al@(ArticlesList {full}) = do
+ preview <- Article.preview <$> (asks $skin.$previewLinesCount)
+ h2_ . toHtml =<< description al
+ ul_ $ do
+ asks hasRSS >>= rssLink
+ li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
+ div_ [class_ "articles"] (
+ mapM_ (mDContent False . preview) =<< getArticles al
+ )
+ where
+ 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 ()
+
+mDContent :: Bool -> Markdown -> HtmlGenerator ()
+mDContent raw markdown@(Markdown {key, body}) =
+ article_ [id_ $ pack key] (do
+ header_ . h1_ $ mDLink raw markdown
+ pre_ . toHtml $ unlines body
+ )
+
+mDLink :: Bool -> Markdown -> HtmlGenerator ()
+mDLink raw (Markdown {Markdown.path, title}) =
+ a_ [href_ $ pack url] $ toHtml title
+ where
+ url = absoluteLink $ path <.> (if raw then "md" else "html")
+
+tag :: String -> HtmlGenerator ()
+tag name =
+ a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name
+
+defaultBanner :: HtmlGenerator ()
+defaultBanner =
+ div_ [id_ "header"] (
+ a_ [href_ "/"] (
+ h1_ . toHtml =<< asks name
+ )
+ )
+
+faviconLink :: FilePath -> HtmlGenerator ()
+faviconLink url = link_ [
+ rel_ "shortcut icon", href_ . pack $ absoluteLink url, type_ "image/x-icon"
+ ]
+
+optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
+optional = maybe (return ())
+
+navigationSection ::
+ Text -> String -> ((String, a) -> HtmlGenerator ()) -> Map String a -> HtmlGenerator ()
+navigationSection sectionId templateKey generator collection
+ | null collection = return ()
+ | otherwise =
+ div_ [id_ sectionId, class_ "navigator"] (do
+ h2_ . toHtml =<< template templateKey []
+ ul_ . mapM_ (li_ . generator) $ Map.toList collection
+ )
+
+htmlDocument :: HasContent a => a -> HtmlGenerator ()
+htmlDocument someContent =
+ doctypehtml_ (do
+ head_ (do
+ meta_ [charset_ "utf-8"]
+ title_ . toHtml =<< asks name
+ script_ [src_ "/js/remarkable.min.js"] empty
+ script_ [src_ "/js/hablo.js"] empty
+ optional faviconLink =<< (asks $skin.$favicon)
+ optional (Card.make someContent) =<< (asks $urls.$cards)
+ optional toHtmlRaw =<< (asks $skin.$head)
+ )
+ body_ (do
+ maybe defaultBanner toHtmlRaw =<< (asks $skin.$banner)
+ asks tags >>= navigationSection "tags" "tagsList"
+ (\(key, _) -> tag key)
+ asks pages >>= navigationSection "pages" "pagesList"
+ (\(_, page) -> mDLink False $ getMarkdown page)
+ div_ [id_ "contents"] $ content someContent
+ )
+ )
diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs
new file mode 100644
--- /dev/null
+++ b/src/DOM/Card.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+module DOM.Card (
+ HasCard(..)
+ , make
+ ) where
+
+import Article (Article(..))
+import ArticlesList (ArticlesList(..))
+import qualified ArticlesList (description)
+import Blog (Blog(..), Renderer, Skin(..), template)
+import Collection (Collection(..))
+import qualified Collection (title)
+import Control.Applicative ((<|>))
+import Control.Monad.Reader (asks)
+import qualified Data.Map as Map (lookup)
+import Data.Text (Text, pack)
+import Lucid (HtmlT, content_, meta_)
+import Lucid.Base (makeAttribute)
+import Markdown (MarkdownContent(..), metadata)
+import qualified Markdown (Markdown(..))
+import Page (Page(..))
+import Pretty ((.$))
+import System.FilePath.Posix ((), (<.>))
+
+class HasCard a where
+ cardType :: Renderer m => a -> m Text
+ description :: Renderer m => a -> m Text
+ image :: Renderer m => a -> m (Maybe String)
+ title :: Renderer m => a -> m String
+ urlPath :: Renderer m => a -> m String
+
+og :: Applicative m => Text -> Text -> HtmlT m ()
+og attribute value =
+ meta_ [
+ makeAttribute "property" $ "og:" <> attribute
+ , content_ value
+ ]
+
+make :: (HasCard a, Renderer m) => a -> String -> HtmlT m ()
+make element siteURL = do
+ og "url" . sitePrefix =<< urlPath element
+ og "type" =<< cardType element
+ og "title" . pack =<< title element
+ og "description" =<< description element
+ maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage))
+ og "site_name" =<< (asks $name.$pack)
+ where
+ maybeImage = maybe (return ()) (og "image" . sitePrefix)
+ sitePrefix = pack . (siteURL )
+
+mDImage :: (Renderer m, MarkdownContent a ) => a -> m (Maybe String)
+mDImage = return . Map.lookup "featuredImage" . metadata . getMarkdown
+
+mDTitle :: (Renderer m, MarkdownContent a) => a -> m String
+mDTitle = return . Markdown.title . getMarkdown
+
+mDUrlPath :: (Renderer m, MarkdownContent a) => a -> m String
+mDUrlPath a = return $ Markdown.path (getMarkdown a) <.> "html"
+
+mDDescription :: (Renderer m, MarkdownContent a) => String -> a -> m Text
+mDDescription key =
+ getDescription . Map.lookup "summary" . metadata . getMarkdown
+ where
+ getDescription = maybe defaultDescription (return . pack)
+ defaultDescription = asks name >>= template key . \v -> [("name", pack v)]
+
+instance HasCard Article where
+ cardType _ = return "article"
+ description = mDDescription "articleDescription"
+ image = mDImage
+ title = mDTitle
+ urlPath = mDUrlPath
+
+instance HasCard Page where
+ cardType _ = return "website"
+ description = mDDescription "pageDescription"
+ image = mDImage
+ title = mDTitle
+ urlPath = mDUrlPath
+
+instance HasCard ArticlesList where
+ cardType _ = return "website"
+ description = ArticlesList.description
+ image _ = return Nothing
+ title (ArticlesList {collection}) = Collection.title collection
+ urlPath al@(ArticlesList {collection}) =
+ return $ maybe "" id (tag collection) file
+ where
+ file = (if full al then "all" else "index") <.> ".html"
diff --git a/src/Dom.hs b/src/Dom.hs
deleted file mode 100644
--- a/src/Dom.hs
+++ /dev/null
@@ -1,115 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Dom (
- page
- ) where
-
-import Article (Article(..))
-import qualified Article (preview)
-import ArticlesList (ArticlesList(..), otherUrl, pageTitle)
-import Blog (Blog(..), Path(..), Skin(..), Wording(..))
-import qualified Blog (get)
-import Control.Applicative ((<|>))
-import Control.Monad.Reader (ReaderT)
-import qualified Data.Map as Map (keys, lookup)
-import Data.Monoid ((<>))
-import Data.Text (Text, pack, empty)
-import Files (absoluteLink)
-import Lucid
-import Lucid.Base (makeAttribute)
-import Prelude hiding (head, lookup)
-import Pretty ((.$))
-import System.FilePath.Posix ((), (<.>))
-
-type HtmlGenerator = HtmlT (ReaderT Blog IO)
-
-class Page a where
- card :: a -> HtmlGenerator ()
- content :: a -> HtmlGenerator ()
-
-instance Page Article where
- card (Article {title, Article.metadata}) = do
- description <- getDescription (Map.lookup "summary" metadata)
- makeCard title (pack description) (Map.lookup "featuredImage" metadata)
- where
- getDescription = maybe (Blog.get $name.$("A new article on " <>)) return
-
- content = article True
-
-instance Page ArticlesList where
- card al = do
- cardTitle <- getTitle <$> Blog.get name
- description <- pageTitle al
- makeCard cardTitle description Nothing
- where
- getTitle name = maybe name ((name ++ " - ") ++) $ tagged al
-
- content al@(ArticlesList {featured, full}) = do
- preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount)
- h2_ . toHtml =<< pageTitle al
- a_ [href_ . pack $ otherUrl al] . toHtml =<< otherLink
- div_ [class_ "articles"] (
- mapM_ (article False . preview) featured
- )
- where
- otherLink = Blog.get $wording.$(if full then latestLink else allLink)
-
-article :: Bool -> Article -> HtmlGenerator ()
-article raw (Article {key, body, title}) = do
- url <- absoluteLink . ( key <.> extension) <$> (Blog.get $path.$articlesPath)
- article_ [id_ $ pack key] (do
- header_ (do
- a_ [href_ . pack $ url] . h1_ $ toHtml title
- )
- pre_ . toHtml $ unlines body
- )
- where extension = if raw then "md" else "html"
-
-makeCard :: String -> Text -> Maybe String -> HtmlGenerator ()
-makeCard title description image = do
- og "title" $ pack title
- og "description" description
- maybeImage =<< ((image <|>) <$> (Blog.get $skin.$cardImage))
- og "site_name" =<< (Blog.get $name.$pack)
- where
- og attribute value = meta_ [makeAttribute "property" $ "og:" <> attribute , content_ value]
- maybeImage = maybe (return ()) (og "image" . pack)
-
-tag :: String -> HtmlGenerator ()
-tag tagName = li_ (
- a_ [href_ . pack $ absoluteLink tagName, class_ "tag"] $ toHtml tagName
- )
-
-defaultBanner :: HtmlGenerator ()
-defaultBanner = do
- div_ [id_ "header"] (
- a_ [href_ "/"] (
- h1_ . toHtml =<< Blog.get name
- )
- )
-
-faviconLink :: FilePath -> HtmlGenerator ()
-faviconLink url = link_ [rel_ "shortcut icon", href_ $ pack url, type_ "image/x-icon"]
-
-page :: Page a => a -> HtmlGenerator ()
-page aPage =
- doctypehtml_ (do
- head_ (do
- meta_ [charset_ "utf-8"]
- title_ . toHtml =<< Blog.get name
- script_ [src_ "/js/unit.js"] empty
- script_ [src_ "/js/remarkable.min.js"] empty
- script_ [src_ "/js/hablo.js"] empty
- maybe (toHtml empty) faviconLink =<< (Blog.get $skin.$favicon)
- card aPage
- (Blog.get $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
- )
- body_ (do
- maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
- div_ [id_ "navigator"] (do
- h2_ =<< (Blog.get $wording.$tagsList.$toHtml)
- ul_ . mapM_ tag . Map.keys =<< Blog.get tags
- )
- div_ [id_ "contents"] $ content aPage
- )
- )
diff --git a/src/Files.hs b/src/Files.hs
--- a/src/Files.hs
+++ b/src/Files.hs
@@ -1,35 +1,32 @@
module Files (
File(..)
- , absolute
, absoluteLink
, filePath
, find
) where
-import System.Exit (die)
-import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, makeAbsolute)
+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
import System.FilePath (())
data File = File FilePath | Dir FilePath
-absolute :: File -> IO (FilePath)
-absolute file = filePath file >>= makeAbsolute
-
absoluteLink :: FilePath -> FilePath
absoluteLink ('.':path) = path
absoluteLink path = "/" path
-filePath :: File -> IO FilePath
-filePath file = do
- let (thePath, test, errorMessage) =
- case file of
- File path -> (path, doesFileExist, (++ ": no such file"))
- Dir path -> (path, doesDirectoryExist, (++ ": no such directory"))
- bool <- test thePath
- if bool
- then return thePath
- else die $ errorMessage thePath
+filePath :: File -> IO (Either String FilePath)
+filePath = filePathAux
+ where
+ filePathAux (File path) = ifIO doesFileExist path Right (notExist . File)
+ filePathAux (Dir path) = ifIO doesDirectoryExist path Right (notExist . Dir)
+ ifIO predicate value whenTrue whenFalse = do
+ result <- predicate value
+ return $ if result then whenTrue value else whenFalse value
+ notExist (File path) = Left $ path ++ ": no such file"
+ notExist (Dir path) = Left $ path ++ ": no such directory"
find :: FilePath -> IO [FilePath]
find path =
- fmap (path ) <$> listDirectory path
+ filePath (Dir path) >>= emptyIfMissing (fmap ((path ) <$>) . listDirectory)
+ where
+ emptyIfMissing = either (\_ -> return [])
diff --git a/src/HTML.hs b/src/HTML.hs
--- a/src/HTML.hs
+++ b/src/HTML.hs
@@ -4,81 +4,43 @@
generate
) where
-import Article(Article(..))
import ArticlesList (ArticlesList(..))
-import Blog (Blog(..), Path(..), Skin(..))
-import qualified Blog (get)
-import Control.Monad (forM)
+import Blog (Blog(..), Path(..))
+import Collection (Collection(..))
+import qualified Collection (getAll)
import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Reader (MonadReader(..), ReaderT)
-import Data.List (sortOn)
-import Data.Map ((!))
-import qualified Data.Map as Map (elems, filterWithKey, toList)
-import Data.Ord (Down(..))
-import qualified Data.Set as Set (member)
+import Control.Monad.Reader (ReaderT, asks)
+import qualified Data.Map as Map (elems)
import qualified Data.Text.Lazy.IO as TextIO (writeFile)
-import Dom (page)
-import Lucid
+import DOM (HasContent, htmlDocument)
+import Lucid (renderTextT)
+import Markdown (Markdown(..), MarkdownContent(..))
import Pretty ((.$))
-import System.Directory (createDirectoryIfMissing)
import System.FilePath.Posix ((), (<.>))
-data Collection = Collection {
- articlesFeatured :: [Article]
- , basePath :: FilePath
- , tag :: Maybe String
- }
-
-collection :: Monad m => [Article] -> Maybe String -> ReaderT Blog m Collection
-collection articlesFeatured tag = do
- root <- Blog.get $path.$root
- return $ Collection {
- articlesFeatured = sortByDate articlesFeatured
- , basePath = maybe root (root ) tag
- , tag
- }
+articlesLists :: Collection -> [(FilePath, ArticlesList)]
+articlesLists collection@(Collection {basePath}) = [
+ (path full, ArticlesList {collection, full}) | full <- [False, True]
+ ]
where
- sortByDate = sortOn (Down . (! "date") . metadata)
-
-articlesLists :: Monad m => Collection -> ReaderT Blog m [(FilePath, ArticlesList)]
-articlesLists (Collection {articlesFeatured, basePath, tag}) = do
- limit <- take <$> (Blog.get $skin.$previewArticlesCount)
- return [
- (basePath "index.html", ArticlesList {
- tagged = tag
- , full = False
- , featured = limit articlesFeatured
- })
- , (basePath "all.html", ArticlesList {
- tagged = tag
- , full = True
- , featured = articlesFeatured
- })
- ]
+ file bool = if bool then "all" else "index"
+ path bool = basePath file bool <.> "html"
-generateArticles :: [Article] -> ReaderT Blog IO ()
-generateArticles = mapM_ $ \article -> do
- baseDir <- () <$> (Blog.get $path.$root) <*> (Blog.get $path.$articlesPath)
- (renderTextT $ page article)
- >>= liftIO . TextIO.writeFile (baseDir key article <.> "html")
+generateMarkdown :: (HasContent a, MarkdownContent a) => [a] -> ReaderT Blog IO ()
+generateMarkdown = mapM_ $ \content -> do
+ let relativePath = Markdown.path (getMarkdown content) <.> "html"
+ filePath <- ( relativePath) <$> (asks $Blog.path.$root)
+ (renderTextT $ htmlDocument content) >>= liftIO . TextIO.writeFile filePath
generateCollection :: Collection -> ReaderT Blog IO ()
-generateCollection (Collection {articlesFeatured = []}) = return ()
-generateCollection aCollection = do
- liftIO . createDirectoryIfMissing False $ basePath aCollection
- 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 $ htmlDocument articlesList)
+ >>= liftIO . TextIO.writeFile filePath
generate :: ReaderT Blog IO ()
generate = do
- Blog {articles, tags} <- ask
- generateArticles $ Map.elems articles
- collection (Map.elems articles) Nothing >>= generateCollection
- forM (Map.toList tags) $
- \(tag, tagged) -> collection (getArticles tagged articles) $ Just tag
- >>= mapM_ generateCollection
- where
- getArticles tagged = Map.elems . Map.filterWithKey (\k _ -> Set.member k tagged)
+ asks articles >>= generateMarkdown . Map.elems
+ Collection.getAll >>= mapM_ generateCollection
+ asks pages >>= generateMarkdown . Map.elems
diff --git a/src/JS.hs b/src/JS.hs
--- a/src/JS.hs
+++ b/src/JS.hs
@@ -3,38 +3,56 @@
generate
) where
+import Data.Aeson (encode)
+
import Blog (Blog(..), Path(..))
-import qualified Blog (get)
import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Reader (ReaderT)
-import Data.ByteString.Lazy (ByteString, concat, readFile, writeFile)
+import Control.Monad.Reader (ReaderT, asks)
+import Data.ByteString.Lazy (
+ ByteString, concat, intercalate, fromStrict, readFile, writeFile
+ )
import Data.ByteString.Lazy.Char8 (pack)
-import qualified Files (find)
+import Data.Text.Encoding (encodeUtf8)
import JSON (exportBlog)
import Paths_hablo (getDataDir)
import Pretty ((.$))
+import SJW (compile, source, sourceCode)
import System.Directory (createDirectoryIfMissing)
+import System.Exit (die)
import System.FilePath (())
import Prelude hiding (concat, readFile, writeFile)
-compile :: [ByteString] -> ByteString
-compile sources = concat (header:sources ++ [footer])
+object :: [ByteString] -> ByteString
+object sources = concat [header, intercalate ",\n" sources, footer]
where
- header = "(function() {\n"
- footer = "})();"
+ header = "return {\n"
+ footer = "\n};"
var :: (String, ByteString) -> ByteString
-var (varName, content) = concat ["var ", pack varName, " = ", content, ";\n"]
+var (varName, content) = concat ["\t", pack varName, " : ", content]
-generate :: ReaderT Blog IO ()
-generate = do
- destinationDir <- ( "js") <$> (Blog.get $path.$root)
- blogJSON <- exportBlog
- remarkablePath <- Blog.get $path.$remarkableConfig
+generateConfig :: FilePath -> ReaderT Blog IO ()
+generateConfig destinationDir = do
+ blogJSON <- asks (encode . exportBlog)
+ remarkablePath <- asks $path.$remarkableConfig
liftIO $ do
remarkableJSON <- maybe (return "{html: true}") readFile remarkablePath
- let jsVars = var <$> [("blog", blogJSON), ("remarkableConfig", remarkableJSON)]
- jsFiles <- ( "js") <$> getDataDir >>= Files.find
- jsCode <- mapM readFile jsFiles
- createDirectoryIfMissing False destinationDir
- writeFile (destinationDir "hablo.js") $ compile (jsVars ++ jsCode )
+ let jsVars = [("blog", blogJSON), ("remarkableConfig", remarkableJSON)]
+ writeFile configModule . object $ var <$> jsVars
+ where
+ configModule = destinationDir "Hablo" "Config.js"
+
+generateMain :: FilePath -> IO ()
+generateMain destinationDir = do
+ habloSources <- ( "js") <$> getDataDir
+ result <- compile $ source [destinationDir, "unitJS", habloSources]
+ maybe (die "JS compilation failed\n") output =<< sourceCode result
+ where
+ output = writeFile (destinationDir "hablo.js") . fromStrict . encodeUtf8
+
+generate :: ReaderT Blog IO ()
+generate = do
+ destinationDir <- asks $path.$root.$( "js")
+ liftIO . createDirectoryIfMissing True $ destinationDir "Hablo"
+ generateConfig destinationDir
+ liftIO $ generateMain destinationDir
diff --git a/src/JSON.hs b/src/JSON.hs
--- a/src/JSON.hs
+++ b/src/JSON.hs
@@ -4,54 +4,60 @@
exportBlog
) where
-import Article (Article)
-import qualified Article (Article(..))
-import Blog (Blog, Path, Skin, Wording)
+import Blog (Blog, Path, Skin, URL, Wording)
import qualified Blog (Blog(..))
-import Control.Monad.Reader (ReaderT, ask)
-import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions, encode)
-import Data.ByteString.Lazy (ByteString)
+import Data.Aeson (Options(..), ToJSON(..), genericToEncoding, defaultOptions)
import Data.Map (Map, mapWithKey)
import qualified Data.Map as Map (filter, keys)
import qualified Data.Set as Set (elems, member)
import GHC.Generics
+import Markdown (Markdown, MarkdownContent(..))
+import qualified Markdown (Markdown(..))
-data ArticleExport = ArticleExport {
+data MarkdownExport = MarkdownExport {
title :: String
- , bodyOffset :: Int
, metadata :: Map String String
- , tagged :: [String]
+ , bodyOffset :: Int
+ , tagged :: Maybe [String]
} deriving (Generic)
-instance ToJSON ArticleExport where
- toEncoding = genericToEncoding defaultOptions
+instance ToJSON MarkdownExport where
+ toEncoding = genericToEncoding (defaultOptions {omitNothingFields = True})
-data BlogDB = BlogDB {
- articles :: Map String ArticleExport
+exportMarkdown :: Maybe [String] -> Markdown -> MarkdownExport
+exportMarkdown tagged markdown = MarkdownExport {
+ title = Markdown.title markdown
+ , metadata = Markdown.metadata markdown
+ , bodyOffset = Markdown.bodyOffset markdown
+ , tagged
+ }
+
+data BlogExport = BlogExport {
+ articles :: Map String MarkdownExport
+ , hasRSS :: Bool
, path :: Path
+ , pages :: Map String MarkdownExport
, skin :: Skin
, tags :: Map String [String]
+ , urls :: URL
, wording :: Wording
} deriving (Generic)
-instance ToJSON BlogDB where
+instance ToJSON BlogExport where
toEncoding = genericToEncoding defaultOptions
-exportArticle :: Blog -> String -> Article -> ArticleExport
-exportArticle blog key article = ArticleExport {
- title = Article.title article
- , bodyOffset = Article.bodyOffset article
- , metadata = Article.metadata article
- , tagged = Map.keys . Map.filter (Set.member key) $ Blog.tags blog
+exportBlog :: Blog -> BlogExport
+exportBlog blog = BlogExport {
+ articles = getArticles $ getMarkdown <$> Blog.articles blog
+ , hasRSS = Blog.hasRSS blog
+ , pages = getPages $ getMarkdown <$> Blog.pages blog
+ , path = Blog.path blog
+ , skin = Blog.skin blog
+ , tags = Set.elems <$> Blog.tags blog
+ , urls = Blog.urls blog
+ , wording = Blog.wording blog
}
-
-exportBlog :: ReaderT Blog IO ByteString
-exportBlog = do
- blog <- ask
- return . encode $ BlogDB {
- articles = mapWithKey (exportArticle blog) $ Blog.articles blog
- , path = Blog.path blog
- , skin = Blog.skin blog
- , tags = Set.elems <$> Blog.tags blog
- , wording = Blog.wording blog
- }
+ where
+ tag key = Just . Map.keys . Map.filter (Set.member key) $ Blog.tags blog
+ getArticles = mapWithKey (exportMarkdown . tag)
+ getPages = mapWithKey (\_-> exportMarkdown Nothing)
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -8,6 +8,7 @@
import qualified HTML (generate)
import qualified JS (generate)
import qualified Paths_hablo as Hablo (version)
+import qualified RSS (generate)
import System.Exit (exitSuccess)
main :: IO ()
@@ -18,4 +19,5 @@
config@(BlogConfig {}) -> Blog.build config >>= runReaderT (do
HTML.generate
JS.generate
+ RSS.generate
)
diff --git a/src/Markdown.hs b/src/Markdown.hs
new file mode 100644
--- /dev/null
+++ b/src/Markdown.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Markdown (
+ Markdown(..)
+ , MarkdownContent(..)
+ , Metadata
+ , at
+ , getKey
+ ) where
+
+import Control.Applicative ((<|>))
+import Data.Map (Map)
+import qualified Data.Map as Map (fromList)
+import System.FilePath (dropExtension, takeFileName)
+import Text.ParserCombinators.Parsec (
+ ParseError, Parser
+ , ()
+ , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf
+ , oneOf, option, parse, skipMany, sourceLine, sourceName, string, try
+ )
+
+type Metadata = Map String String
+data Markdown = Markdown {
+ key :: String
+ , path :: String
+ , title :: String
+ , metadata :: Metadata
+ , bodyOffset :: Int
+ , body :: [String]
+ }
+
+class MarkdownContent a where
+ getMarkdown :: a -> Markdown
+
+parser :: Parser Markdown
+parser = do
+ (title, metadata) <- skipMany eol *> (headerP <|> reverseHeaderP)
+ bodyOffset <- skipMany eol *> (pred . sourceLine <$> getPosition)
+ body <- lines <$> many anyChar <* eof
+ inputFile <- sourceName <$> getPosition
+ let (key, path) = (getKey inputFile, dropExtension inputFile)
+ return $ Markdown {key, path, title, metadata, bodyOffset, body}
+ where
+ headerP = (,) <$> titleP <* many eol <*> metadataP
+ reverseHeaderP = flip (,) <$> metadataP <* many eol<*> titleP
+
+metadataP :: Parser Metadata
+metadataP = Map.fromList <$> option [] (
+ metaSectionSeparator *> many eol *>
+ (try keyVal) `endBy` (many1 eol)
+ <* metaSectionSeparator
+ ) "metadata section"
+ where
+ metaSectionSeparator = count 3 (oneOf "~-") *> eol
+ spaces = skipMany $ char ' '
+ keyVal = (,) <$> (no ": \r\n" <* spaces <* char ':' <* spaces) <*> no "\r\n"
+
+titleP :: Parser String
+titleP = try (singleLine <|> underlined)
+ where
+ singleLine = char '#' *> char ' ' *> no "\r\n" <* eol
+ underlined =
+ no "\r\n" <* eol
+ >>= \titleLine -> count (length titleLine) (oneOf "#=") *> eol *> return titleLine
+ "'#' or '=' to underline the title"
+
+eol :: Parser String
+eol = try (string "\r\n") <|> string "\r" <|> string "\n" "newline"
+
+no :: String -> Parser String
+no = many1 . noneOf
+
+getKey :: FilePath -> String
+getKey = dropExtension . takeFileName
+
+at :: FilePath -> IO (Either ParseError Markdown)
+at filePath = parse parser filePath <$> readFile filePath
diff --git a/src/Page.hs b/src/Page.hs
new file mode 100644
--- /dev/null
+++ b/src/Page.hs
@@ -0,0 +1,17 @@
+module Page (
+ Page(..)
+ , at
+ ) where
+
+import Markdown (Markdown(..), MarkdownContent(..))
+import qualified Markdown as Markdown (at)
+import Text.ParserCombinators.Parsec (ParseError)
+
+newtype Page = Page Markdown
+instance MarkdownContent Page where
+ getMarkdown (Page markdown) = markdown
+
+at :: FilePath -> IO (Either ParseError (String, Page))
+at filePath = fmap makePage <$> Markdown.at filePath
+ where
+ makePage markdown = (key markdown, Page markdown)
diff --git a/src/Pretty.hs b/src/Pretty.hs
--- a/src/Pretty.hs
+++ b/src/Pretty.hs
@@ -1,6 +1,16 @@
module Pretty (
- (.$)
+ (.$)
+ , assertRight
+ , onRight
) where
+import System.Exit (die)
+
(.$) :: (a -> b) -> (b -> c) -> (a -> c)
(.$) f g = g . f
+
+onRight :: (a -> IO b) -> Either String a -> IO b
+onRight = either die
+
+assertRight :: Either String a -> IO a
+assertRight = onRight return
diff --git a/src/RSS.hs b/src/RSS.hs
new file mode 100644
--- /dev/null
+++ b/src/RSS.hs
@@ -0,0 +1,93 @@
+{-# 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 = toHtmlRaw ("" :: 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 (Markdown {path, metadata, title})) =
+ item_ $ do
+ title_ $ toHtml title
+ link_ $ toHtml (siteURL path <.> "html")
+ pubDate_ . toHtml . rfc822Date $ metadata ! "date"
+ where
+ 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)
diff --git a/test/Mock/Arguments.hs b/test/Mock/Arguments.hs
new file mode 100644
--- /dev/null
+++ b/test/Mock/Arguments.hs
@@ -0,0 +1,86 @@
+module Mock.Arguments (
+ badCustomArticles
+ , badCustomPages
+ , bothCustom
+ , bothDefault
+ , customArticles
+ , customArticlesDefaultPages
+ , customPages
+ , customPagesDefaultArticles
+ , defaultArticles
+ , defaultPages
+ , emptyBlog
+ ) where
+
+import Arguments (Arguments(..))
+import Utils (testDataPath)
+
+defaultArticles :: Arguments
+defaultArticles = BlogConfig {
+ sourceDir = testDataPath "Structure/defaultArticles"
+ , articlesPath = Nothing
+ , bannerPath = Nothing
+ , cardImage = Nothing
+ , commentsURL = Nothing
+ , favicon = Nothing
+ , headPath = Nothing
+ , name = Nothing
+ , openGraphCards = False
+ , pagesPath = Nothing
+ , previewArticlesCount = 3
+ , previewLinesCount = 10
+ , remarkableConfig = Nothing
+ , rss = False
+ , siteURL = Nothing
+ , wording = Nothing
+ }
+
+defaultPages :: Arguments
+defaultPages = defaultArticles {
+ sourceDir = testDataPath "Structure/defaultPages"
+ }
+
+bothDefault :: Arguments
+bothDefault = defaultArticles {
+ sourceDir = testDataPath "Structure/both"
+ }
+
+emptyBlog :: Arguments
+emptyBlog = defaultArticles {
+ sourceDir = testDataPath "Structure/custom"
+ }
+
+customArticles :: Arguments
+customArticles = emptyBlog {
+ articlesPath = Just "customArticles"
+ }
+
+customArticlesDefaultPages :: Arguments
+customArticlesDefaultPages = bothDefault {
+ articlesPath = Just "customArticles"
+ }
+
+customPages :: Arguments
+customPages = emptyBlog {
+ pagesPath = Just "customPages"
+ }
+
+customPagesDefaultArticles :: Arguments
+customPagesDefaultArticles = bothDefault {
+ pagesPath = Just "customPages"
+ }
+
+bothCustom :: Arguments
+bothCustom = customArticles {
+ pagesPath = Just "customPages"
+ }
+
+badCustomArticles :: Arguments
+badCustomArticles = bothDefault {
+ articlesPath = Just "missingDirectory"
+ }
+
+badCustomPages :: Arguments
+badCustomPages = bothDefault {
+ pagesPath = Just "missingDirectory"
+ }
diff --git a/test/Mock/Article.hs b/test/Mock/Article.hs
new file mode 100644
--- /dev/null
+++ b/test/Mock/Article.hs
@@ -0,0 +1,23 @@
+module Mock.Article (
+ noDescription
+ , noImage
+ , noMeta
+ , simple
+ ) where
+
+import Article (Article(..))
+import qualified Data.Map as Map (fromList)
+import Markdown (Markdown(..))
+import Mock.Markdown (article)
+
+simple :: Article
+simple = Article article
+
+noImage :: Article
+noImage = Article $ article {metadata = Map.fromList [("summary", "It's a test")]}
+
+noDescription :: Article
+noDescription = Article $ article {metadata = Map.fromList [("featuredImage", "test.png")]}
+
+noMeta :: Article
+noMeta = Article $ article {metadata = Map.fromList []}
diff --git a/test/Mock/ArticlesList.hs b/test/Mock/ArticlesList.hs
new file mode 100644
--- /dev/null
+++ b/test/Mock/ArticlesList.hs
@@ -0,0 +1,22 @@
+module Mock.ArticlesList (
+ longMain
+ , longTesting
+ , shortMain
+ , shortTesting
+ ) where
+
+import ArticlesList (ArticlesList(..))
+import Mock.Collection (main, testing)
+import Prelude hiding (all)
+
+shortMain :: IO ArticlesList
+shortMain = ArticlesList False <$> main
+
+shortTesting :: IO ArticlesList
+shortTesting = ArticlesList False <$> testing
+
+longMain :: IO ArticlesList
+longMain = ArticlesList True <$> main
+
+longTesting :: IO ArticlesList
+longTesting = ArticlesList True <$> testing
diff --git a/test/Mock/Blog.hs b/test/Mock/Blog.hs
new file mode 100644
--- /dev/null
+++ b/test/Mock/Blog.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Mock.Blog (
+ noCards
+ , noRSS
+ , simple
+ ) where
+
+import Blog (Blog(..))
+import qualified Data.Map as Map (fromList)
+import qualified Data.Set as Set (fromList)
+import qualified Mock.Article (simple)
+import qualified Mock.Blog.Path (defaultArticles)
+import qualified Mock.Blog.Skin (simple)
+import qualified Mock.Blog.Template (simple)
+import qualified Mock.Blog.URL (simple, noCards)
+import qualified Mock.Blog.Wording (defaultWording)
+
+simple :: IO Blog
+simple =
+ let wording = Mock.Blog.Wording.defaultWording in do
+ templates <- Mock.Blog.Template.simple
+ return $ Blog {
+ articles = Map.fromList [("test", Mock.Article.simple)]
+ , hasRSS = True
+ , name = "The Test Blog"
+ , pages = Map.fromList []
+ , path = Mock.Blog.Path.defaultArticles
+ , skin = Mock.Blog.Skin.simple
+ , tags = Map.fromList [("testing", Set.fromList ["test"])]
+ , templates
+ , urls = Mock.Blog.URL.simple
+ , wording
+ }
+
+noCards :: IO Blog
+noCards = (\b -> b {urls = Mock.Blog.URL.noCards}) <$> simple
+
+noRSS :: IO Blog
+noRSS = (\b -> b {hasRSS = False}) <$> simple
diff --git a/test/Mock/Blog/Path.hs b/test/Mock/Blog/Path.hs
new file mode 100644
--- /dev/null
+++ b/test/Mock/Blog/Path.hs
@@ -0,0 +1,66 @@
+module Mock.Blog.Path (
+ bothCustom
+ , bothDefault
+ , customArticles
+ , customArticlesDefaultPages
+ , customPages
+ , customPagesDefaultArticles
+ , defaultArticles
+ , defaultPages
+ ) where
+
+import Blog.Path (Path(..))
+
+defaultArticles :: Path
+defaultArticles = Path {
+ articlesPath = Just "articles"
+ , pagesPath = Nothing
+ , remarkableConfig = Nothing
+ , root = "test/Structure/defaultArticles"
+ }
+
+defaultPages :: Path
+defaultPages = Path {
+ articlesPath = Nothing
+ , pagesPath = Just "pages"
+ , remarkableConfig = Nothing
+ , root = "test/Structure/defaultPages"
+ }
+
+bothDefault :: Path
+bothDefault = Path {
+ articlesPath = Just "articles"
+ , pagesPath = Just "pages"
+ , remarkableConfig = Nothing
+ , root = "test/Structure/both"
+ }
+
+customArticles :: Path
+customArticles = Path {
+ articlesPath = Just "customArticles"
+ , pagesPath = Nothing
+ , remarkableConfig = Nothing
+ , root = "test/Structure/custom"
+ }
+
+bothCustom :: Path
+bothCustom = customArticles {
+ pagesPath = Just "customPages"
+ }
+
+customPages :: Path
+customPages = bothCustom {
+ articlesPath = Nothing
+ }
+
+customArticlesDefaultPages :: Path
+customArticlesDefaultPages = bothDefault {
+ articlesPath = Just "customArticles"
+ , pagesPath = Just "pages"
+ }
+
+customPagesDefaultArticles :: Path
+customPagesDefaultArticles = customArticlesDefaultPages {
+ articlesPath = Just "articles"
+ , pagesPath = Just "customPages"
+ }
diff --git a/test/Mock/Blog/Skin.hs b/test/Mock/Blog/Skin.hs
new file mode 100644
--- /dev/null
+++ b/test/Mock/Blog/Skin.hs
@@ -0,0 +1,16 @@
+module Mock.Blog.Skin (
+ simple
+ ) where
+
+import Blog.Skin (Skin(..))
+import Prelude hiding (head)
+
+simple :: Skin
+simple = Skin {
+ banner = Nothing
+ , cardImage = Nothing
+ , favicon = Nothing
+ , head = Nothing
+ , previewArticlesCount = 3
+ , previewLinesCount = 10
+ }
diff --git a/test/Mock/Blog/Template.hs b/test/Mock/Blog/Template.hs
new file mode 100644
--- /dev/null
+++ b/test/Mock/Blog/Template.hs
@@ -0,0 +1,9 @@
+module Mock.Blog.Template (
+ simple
+ ) where
+
+import Blog.Template (Templates, build)
+import Mock.Blog.Wording (defaultWording)
+
+simple :: IO Templates
+simple = build Mock.Blog.Wording.defaultWording
diff --git a/test/Mock/Blog/URL.hs b/test/Mock/Blog/URL.hs
new file mode 100644
--- /dev/null
+++ b/test/Mock/Blog/URL.hs
@@ -0,0 +1,16 @@
+module Mock.Blog.URL (
+ noCards
+ , simple
+ ) where
+
+import Blog.URL (URL(..))
+
+simple :: URL
+simple = URL {
+ cards = Just "https://test.net"
+ , comments = Nothing
+ , rss = Nothing
+ }
+
+noCards :: URL
+noCards = simple {cards = Nothing}
diff --git a/test/Mock/Blog/Wording.hs b/test/Mock/Blog/Wording.hs
new file mode 100644
--- /dev/null
+++ b/test/Mock/Blog/Wording.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Mock.Blog.Wording (
+ defaultWording
+ ) where
+
+import Blog.Wording (Wording(..))
+import qualified Data.Map as Map (fromList)
+
+defaultWording :: Wording
+defaultWording = Wording $ Map.fromList [
+ ("allLink", "See all")
+ , ("allPage", "All articles{? tagged ${tag}?}")
+ , ("articleDescription", "A new article on ${name}")
+ , ("commentsLink", "Comment on the fediverse")
+ , ("commentsSection", "Comments")
+ , ("dateFormat", "en-US")
+ , ("latestLink", "See only latest")
+ , ("latestPage", "Latest articles{? tagged ${tag}?}")
+ , ("metadata", "{?by ${author} ?}on ${date}{? tagged ${tags}?}")
+ , ("pageDescription", "Read on ${name}")
+ , ("pagesList", "Pages")
+ , ("rssLink", "Subscribe")
+ , ("rssTitle", "Follow all articles{? tagged ${tag}?}")
+ , ("tagsList", "Tags")
+ ]
diff --git a/test/Mock/Collection.hs b/test/Mock/Collection.hs
new file mode 100644
--- /dev/null
+++ b/test/Mock/Collection.hs
@@ -0,0 +1,28 @@
+module Mock.Collection (
+ main
+ , testing
+ ) where
+
+import Blog (Blog(..), Path(..))
+import Collection (Collection(..))
+import Data.Map as Map (elems)
+import qualified Mock.Blog (simple)
+import System.FilePath (())
+
+main :: IO Collection
+main = do
+ blog <- Mock.Blog.simple
+ return $ Collection {
+ featured = Map.elems $ articles blog
+ , basePath = root $ path blog
+ , tag = Nothing
+ }
+
+testing :: IO Collection
+testing = do
+ blog <- Mock.Blog.simple
+ return $ Collection {
+ featured = Map.elems $ articles blog
+ , basePath = root (path blog) "testing"
+ , tag = Just "testing"
+ }
diff --git a/test/Mock/Markdown.hs b/test/Mock/Markdown.hs
new file mode 100644
--- /dev/null
+++ b/test/Mock/Markdown.hs
@@ -0,0 +1,33 @@
+module Mock.Markdown (
+ article
+ , page
+ ) where
+
+import qualified Data.Map as Map (fromList)
+import Markdown (Markdown(..))
+
+article :: Markdown
+article = Markdown {
+ key = "test"
+ , path = "articles/test"
+ , Markdown.title = "Some test"
+ , metadata = Map.fromList [
+ ("summary", "It's a test")
+ , ("featuredImage", "test.png")
+ ]
+ , bodyOffset = 3
+ , body = []
+ }
+
+page :: Markdown
+page = Markdown {
+ key = "test"
+ , path = "pages/test"
+ , Markdown.title = "A test page"
+ , metadata = Map.fromList [
+ ("summary", "Tests are useful")
+ , ("featuredImage", "test.png")
+ ]
+ , bodyOffset = 3
+ , body = []
+ }
diff --git a/test/Structure.hs b/test/Structure.hs
new file mode 100644
--- /dev/null
+++ b/test/Structure.hs
@@ -0,0 +1,40 @@
+module Structure (
+ test
+ ) where
+
+import Arguments (Arguments(..))
+import Blog (Path)
+import qualified Blog.Path as Path (build)
+import Distribution.TestSuite
+import qualified Mock.Arguments as Arguments
+import qualified Mock.Blog.Path as Path
+import System.Directory (withCurrentDirectory)
+import Utils (simpleTest, tag)
+
+checkPath :: Arguments -> Maybe Path -> IO Progress
+checkPath input expected = do
+ withCurrentDirectory root $ do
+ actual <- either (\_ -> Nothing) Just <$> Path.build root input
+ return . Finished $
+ if actual == expected
+ then Pass
+ else Fail $ "Expected " ++ show expected ++ " but got " ++ show actual
+ where
+ root = sourceDir input
+
+test :: Test
+test = tag "structure" . testGroup "Blog structure" $ simpleTest <$> [
+ ("empty structure", checkPath Arguments.emptyBlog Nothing)
+ , ("default articles", checkPath Arguments.defaultArticles $ Just Path.defaultArticles)
+ , ("default pages", checkPath Arguments.defaultPages $ Just Path.defaultPages)
+ , ("both default", checkPath Arguments.bothDefault $ Just Path.bothDefault)
+ , ("custom articles", checkPath Arguments.customArticles $ Just Path.customArticles)
+ , ("custom pages", checkPath Arguments.customPages $ Just Path.customPages)
+ , ("both custom", checkPath Arguments.bothCustom $ Just Path.bothCustom)
+ , ("custom articles, default pages"
+ , checkPath Arguments.customArticlesDefaultPages $ Just Path.customArticlesDefaultPages)
+ , ("custom pages, default articles"
+ , checkPath Arguments.customPagesDefaultArticles $ Just Path.customPagesDefaultArticles)
+ , ("bad custom articles", checkPath Arguments.badCustomArticles $ Nothing)
+ , ("bad custom pages", checkPath Arguments.badCustomPages $ Nothing)
+ ]
diff --git a/test/Tests.hs b/test/Tests.hs
new file mode 100644
--- /dev/null
+++ b/test/Tests.hs
@@ -0,0 +1,14 @@
+module Tests (
+ tests
+ ) where
+
+import Distribution.TestSuite
+import qualified Structure (test)
+import Utils (tag)
+import qualified XML.Card (test)
+
+tests :: IO [Test]
+tests = return $ tag "xml" <$> [
+ XML.Card.test
+ , Structure.test
+ ]
diff --git a/test/Utils.hs b/test/Utils.hs
new file mode 100644
--- /dev/null
+++ b/test/Utils.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Utils (
+ assertAll
+ , assertEqual
+ , simpleTest
+ , tag
+ , testDataPath
+ ) where
+
+import Distribution.TestSuite
+import System.FilePath (())
+import Text.Printf (printf)
+
+tagInstance :: String -> TestInstance -> TestInstance
+tagInstance tagName testInstance = testInstance {
+ tags = tagName : (tags testInstance)
+ }
+
+tag :: String -> Test -> Test
+tag tagName (Test testInstance) = Test (tagInstance tagName testInstance)
+tag tagName group = group {groupTests = tag tagName <$> groupTests group}
+
+simpleTest :: (String, IO Progress) -> Test
+simpleTest (name, run) = Test testInstance
+ where
+ testInstance = TestInstance {
+ run
+ , name
+ , tags = []
+ , options = []
+ , setOption = \_ _ -> Right testInstance
+ }
+
+wrong :: Show a => String -> a -> a -> IO Progress
+wrong message expected actual = return . Finished . Fail $
+ printf "%s: %s vs. %s" message (show expected) (show actual)
+
+assertAll :: [(Bool, IO Progress, String)] -> IO Progress
+assertAll = foldr assert (return $ Finished Pass)
+ where
+ assert (bool, badIssue, checkMessage) next =
+ if bool then return $ Progress checkMessage next else badIssue
+
+assertEqual :: (Show a, Eq a) => String -> a -> a -> (Bool, IO Progress, String)
+assertEqual what a b =
+ (a == b, wrong (what ++ " do not match !") a b, what ++ " ok")
+
+testDataPath :: FilePath -> FilePath
+testDataPath = ("test" )
diff --git a/test/XML/Card.hs b/test/XML/Card.hs
new file mode 100644
--- /dev/null
+++ b/test/XML/Card.hs
@@ -0,0 +1,11 @@
+module XML.Card (
+ test
+ ) where
+
+import Distribution.TestSuite
+import Utils (tag)
+import qualified XML.Card.Component as Component (test)
+import qualified XML.Card.Output as Output (test)
+
+test :: Test
+test = tag "card" $ testGroup "Cards" [Component.test, Output.test]
diff --git a/test/XML/Card/Component.hs b/test/XML/Card/Component.hs
new file mode 100644
--- /dev/null
+++ b/test/XML/Card/Component.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE OverloadedStrings #-}
+module XML.Card.Component (
+ test
+ ) where
+
+import Blog (Blog)
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Reader (runReaderT)
+import Data.Text (Text)
+import Distribution.TestSuite
+import DOM.Card (HasCard(..))
+import Mock.Blog as Blog (simple)
+import Mock.Article as Article (noDescription, noImage, simple)
+import Mock.ArticlesList as ArticlesList (
+ longMain, longTesting, shortMain, shortTesting
+ )
+import Utils (assertAll, assertEqual, simpleTest, tag)
+
+check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO Progress
+check getBlog input (expectedCT, expectedD, expectedI, expectedT, expectedU) =
+ getBlog >>= runReaderT (
+ sequence [
+ assertEqual "card types" expectedCT <$> cardType input
+ , assertEqual "descriptions" expectedD <$> description input
+ , assertEqual "images" expectedI <$> image input
+ , assertEqual "titles" expectedT <$> title input
+ , assertEqual "urls" expectedU <$> urlPath input
+ ] >>= liftIO . assertAll
+ )
+
+articleCard :: Test
+articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
+ ("simple article components", check Blog.simple Article.simple (
+ "article"
+ , "It's a test"
+ , Just "test.png"
+ , "Some test"
+ , "articles/test.html"
+ ))
+ , ("article components without description", check Blog.simple Article.noDescription (
+ "article"
+ , "A new article on The Test Blog"
+ , Just "test.png"
+ , "Some test"
+ , "articles/test.html"
+ ))
+ , ("article components without image", check Blog.simple Article.noImage (
+ "article"
+ , "It's a test"
+ , Nothing
+ , "Some test"
+ , "articles/test.html"
+ ))
+ ]
+
+articlesListCard :: Test
+articlesListCard = tag "articlesList" . testGroup "Articles list cards" $ simpleTest <$> [
+ ("short untagged page component", ArticlesList.shortMain >>= (flip (check Blog.simple) (
+ "website"
+ , "Latest articles"
+ , Nothing
+ , "The Test Blog"
+ , "index.html"
+ )))
+ , ("long untagged page component", ArticlesList.longMain >>= (flip (check Blog.simple) (
+ "website"
+ , "All articles"
+ , Nothing
+ , "The Test Blog"
+ , "all.html"
+ )))
+ , ("short tagged page component", ArticlesList.shortTesting >>= (flip (check Blog.simple) (
+ "website"
+ , "Latest articles tagged testing"
+ , Nothing
+ , "The Test Blog - testing"
+ , "testing/index.html"
+ )))
+ , ("long tagged page component", ArticlesList.longTesting >>= (flip (check Blog.simple) (
+ "website"
+ , "All articles tagged testing"
+ , Nothing
+ , "The Test Blog - testing"
+ , "testing/all.html"
+ )))
+ ]
+
+test :: Test
+test = tag "component" $ testGroup "Cards components" [articleCard, articlesListCard]
diff --git a/test/XML/Card/Output.hs b/test/XML/Card/Output.hs
new file mode 100644
--- /dev/null
+++ b/test/XML/Card/Output.hs
@@ -0,0 +1,49 @@
+module XML.Card.Output (
+ test
+ ) where
+
+import Blog (Blog(..), URL(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Reader (asks, runReaderT)
+import qualified Data.Text.Lazy.IO as Lazy (readFile)
+import Distribution.TestSuite
+import DOM.Card (HasCard(..), make)
+import Lucid (renderTextT)
+import Mock.Blog as Blog (noCards, simple)
+import Mock.Article as Article (noDescription, noImage, simple)
+import Mock.ArticlesList as ArticlesList (
+ longMain, longTesting, shortMain, shortTesting
+ )
+import Pretty ((.$))
+import System.FilePath (())
+import Utils (assertAll, assertEqual, simpleTest, tag, testDataPath)
+
+check :: HasCard a => IO Blog -> a -> FilePath -> IO Progress
+check getBlog input expectedFile =
+ getBlog >>= runReaderT (do
+ actual <- renderTextT $ maybe (return ()) (DOM.Card.make input) =<< (asks $urls.$cards)
+ expected <- liftIO . Lazy.readFile $ testDataPath "XML/Card/Output" expectedFile
+ liftIO $ assertAll [
+ assertEqual "card HTML output" expected actual
+ ]
+ )
+
+articleCard :: Test
+articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
+ ("simple article output", check Blog.simple Article.simple "simple.html")
+ , ("article output without description", check Blog.simple Article.noDescription "noDescription.html")
+ , ("article output without image", check Blog.simple Article.noImage "noImage.html")
+ , ("no card article output", check Blog.noCards Article.simple "/dev/null")
+ ]
+
+articlesListCard :: Test
+articlesListCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
+ ("short untagged page output", ArticlesList.shortMain >>= flip (check Blog.simple) "shortMain.html")
+ , ("long untagged page output", ArticlesList.longMain >>= flip (check Blog.simple) "longMain.html")
+ , ("short tagged page output", ArticlesList.shortTesting >>= flip (check Blog.simple) "shortTesting.html")
+ , ("long tagged page output", ArticlesList.longTesting >>= flip (check Blog.simple) "longTesting.html")
+ , ("no card articlesList output", ArticlesList.shortMain >>= flip (check Blog.noCards) "/dev/null")
+ ]
+
+test :: Test
+test = tag "output" $ testGroup "Cards outputs" [articleCard, articlesListCard]